



		    admin_.pl1                      10/04/90  1640.8rew 10/04/90  1635.1     1150947



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * 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 */

admin_: procedure ();

/* *** The entries in admin_ implement the various operator commands of
   the same name.  They are called as a result of entries in
   sc_request_table_ via sc_process_command_line_. */

/* *** NOTE -- Entries should call sys_log, rather than sys_log_.
   Whenever this program is entered as something other than a
   command (a timer handler or the like) the entry variable
   sys_log is set to the non-command entrypoints in sys_log_,
   otherwise they use the command entrypoints.  Note than recursive
   internal calls have to be capable of doing this right. */

/*
   The following answering service functions are provided by this module
   (entry points are in the order shown):

   *     MISC. COMMANDS

   login		cause a daemon user to be logged in
   logout		cause a daemon user to be logged out
   word		set login word and dialup buffer
   sysid		set system ID (typed at dialup)
   down		schedule automatic shutdown of system at later time
   stop		shut down answering service; bump all users
   warn		blast message onto a user's console
   rcp		reply to RCP requests (only list now implemented)
   log		enter comments in the answering service log.
   maxunits	set maximum number of load units
   shift		set shift and shift change time, overriding shift table

   *     FNP COMMANDS

   fdump_fnp, or	take an fdump of a specified FNP, crashing it if it is up
   dump_fnp
   load_fnp	initiate a bootload of a specified FNP
   start_fnp	listen to the phones configured on a specified FNP
   stop_fnp	prevents booting of specified FNP or listening to its phones

   *	MULTIPLEXER COMMANDS (similiar to fnp commands)

   dump_mpx		take a dump of the specified multiplexer
   load_mpx		initialize the specified multiplexcer
   start_mpx		listen to the phones on a specified multiplexer
   stop_mpx		stop listening to the phones in the specified multiplexer
   shutdowm_mpx               shutdown multiplexer without crash

   *     ABSENTEE COMMANDS

   abs maxu	set maximum absentee users
   abs maxq	set maximum absentee queue
   abs start	start absentee
   abs stop	stop absentee
   abs bump	bump absentee job
   abs cancel	bump and do not restart absentee job
   abs qres	set number of reserved slots for each queue
   abs cpu_limit	set max cpu limit for each queue
   abs defer	do not log job(s) in until they are released
   abs list	list specified job(s)
   abs move	move specified job(s) to different queue
   abs next	log specified job in next
   abs release	allow specified deferred or suspended job(s) to log in or resume running
   abs run	log specified job in immediately
   abs suspend	don't run specified logged-in job until released
   abs terminate	terminate absentee process (bump by simulating fatal process error)

   Modified 750415 by PG to use printer_on order call.
   Modified 751020 by PG to fix bug in DOWN command and delete obsolete TAPE command.
   Modified May 1976 by T. Casey to implement SHIFT command.
   Modified July, 1976 by D. M. Wells to understand bumping FTP channels
   Modified 760819 by  Roy Planalp to produce correct message if chnl with
   no user logged in is detached, and to write ftp-format message when bumping ftp users
   Modified August 1976 by T. Casey and M. Grady to add commands that deal with FNPs
   Modified November 1976 by T. Casey to fix bug in stop_fnp command.
   Modified September 1977 by T. Casey to make drop, accept, substty, detach, and remove treat MC_SERVICE consistently,
   .	and to make the word command with no arguments print current word, session type, and message.
   Modified January 1978 by T. Casey to fix bugs in previous modification.
   Modified May 1978 by T. Casey to add abs qres command, and modify several other commands to print the current values
   .		of the parameters they set, instead of complaining, when no arguments are given.
   Modified August 1978 by Larry Johnson for multiplexer commands
   Modified November 1978 by T. Casey, for new abs command keywords.
   Modified March 1979 by T. Casey for MR7.0a, to add abs terminate, abs suspend, and abs release of suspended jobs.
   Modified August 1979 by T. Casey for MR8.0 to support process preservation across hangups and fix bugs.
   Modified December 1980 by E. N. Kittlitz for Person.Project & bugfixes
   Modified June 1981 by T. Casey for MR9.0 for new wakeup priorities.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981, E. N. Kittlitz.  whotab copies of autbl control info.
   Modified April 1982, E. N. Kittlitz. down: insist uptime > downtime
   Modified May 1982, E. N. Kittlitz. New AS initialization.
   Modified June 1982, E. N. Kittlitz. Kluge MR10.0 stop_mpx support.
   Modified July 1982, E. N. Kittlitz. rename to admin_.
   Modified August 1982, E. N. Kittlitz. dialup_ re-introduction.
   Modified October 1982, E. N. Kittlitz.  minor 'word' fixes.
   Modified 83-12-14, BIM. added shutdown_mpx
   Modified March 1984 by GMP to fix the "word" command to set the special message again.
   Modified 09/10/84 by R. Michael Tague: Changed $down so that
   system_shutdown_scheduled_ IPS is sent to all processes when a shutdown
   is scheduled.
   Modified 1984-11-02, BIM: Stop masking and unmasking, its not our job.
   call the restricting entry in mc_commands_ for quit.
   Modified 84-11-14 for whotab.session. -E. A. Ranzenbach...
   Modified 1985-01-10, BIM: Add calls to mc_check_access_ for quit and
   login/logout.
   Modified 1985-02-07, E. Swenson: to allow cancellation of absentee shutdown
   once one has begun, but not yet been completed.
   Modified 1985-02-13, E. Swenson: to fix bump code.
   Modified 1985-03-12, E. Swenson: to fix system shutdown scheduling.
   Modified 1985-03-22, E. Swenson: to fix drop code.
   Modified 1985-06-28, E. Swenson: allow substty to again work for otw_.
*/

/****^  HISTORY COMMENTS:
  1) change(86-01-09,MSharpe), approve(87-05-01,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Changed to move message coordinator, process and channel comm commands
     to the newly created programs to hold them.  (These commands were
     previously in admin_.)
  2) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  3) change(86-09-26,Beattie), approve(86-09-22,MCR7542),
     audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211):
     Remove references to the 963 and 029 preaccess commands and remove support
     for ARDS, 202_ETX, 2741 and 1050 in system interfaces.
  4) change(87-04-27,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  5) change(87-06-25,Parisek), approve(87-06-25,MCR7690),
     audit(87-07-31,Beattie), install(87-08-04,MR12.1-1055):
     Added a cleanup handler for all entry points thereby nulling all
     pointers to system data bases previously opened up.
  6) change(87-08-06,GDixon), approve(87-08-06,MCR7690),
     audit(87-08-06,Parisek), install(87-08-06,MR12.1-1064):
     Remove the cleanup handler.  It was performing a mis-service by
     terminating segments pointed to by static pointers in as_data_.
  7) change(87-09-18,Parisek), approve(87-09-18,PBF7716),
     audit(87-09-18,Farley), install(87-09-21,MR12.1-1111):
     Correct an incorrectly formatted ioa_ control string.
  8) change(87-10-04,Beattie), approve(87-10-26,MCR7785),
     audit(87-12-04,Parisek), install(87-12-07,MR12.2-1008):
     Accomodate changes in format of date_time strings.
  9) change(88-09-30,Parisek), approve(88-10-19,MCR8014),
     audit(89-01-12,Farley), install(89-01-23,MR12.3-1009):
     Divide installation_parms.warning_time by 60 seconds to produce the
     correct number of minutes a process has left before shutdown which is
     reported by the stop command.
 10) change(90-09-20,Vu), approve(90-09-20,MCR8201), audit(90-09-24,Schroth),
     install(90-10-04,MR12.4-1037):
     Correct the oprerator command "abs stop q fg" which cause queue 1 to stop.
     Absentees are bumped at random time for a scheduled shutdown due to an
     uninitialized value.
                                                   END HISTORY COMMENTS */

/* Entries */

dcl  absentee_user_manager_$aum_abs_run entry (ptr);
dcl  absentee_user_manager_$init_aum entry (fixed bin (35));
dcl  absentee_user_manager_$term_aum entry;
dcl  absentee_user_manager_$update_whotab_abs_control entry;
dcl  absentee_utility_$abs_defer entry (ptr);
dcl  absentee_utility_$abs_release entry (ptr, fixed bin);
dcl  absentee_utility_$au_send_wakeup entry;
dcl  act_ctl_$shift_cmnd_update entry;
dcl  admin_$abs entry options (variable);
dcl  admin_$absentee_down entry;
dcl  admin_$absentee_off entry;
dcl  asu_$bump_user entry (ptr, char (*), fixed bin (35), fixed bin);
dcl  admin_$timed_stop_command entry ();
dcl  asu_$blast_user entry (ptr, char (*), char (*), fixed bin (35));
dcl  available_slots_ entry (fixed bin, fixed bin, (4) fixed bin, (4) fixed bin) returns (fixed bin);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_list_ptr entry returns (ptr);
dcl  cu_$generate_call entry (entry, ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  daemon_user_manager_$login entry (char (*), char (*), char (*), char (*));
dcl  daemon_user_manager_$logout entry (char (*), char (*), char (*));
dcl  dialup_$re_introduce entry;
dcl  multiplexer_mgr_$dump_mpx entry (char (*), bit (1) aligned, fixed bin (35));
dcl  multiplexer_mgr_$load_mpx entry (char (*), bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
dcl  multiplexer_mgr_$start_mpx entry (char (*), bit (1) aligned, fixed bin (35));
dcl  multiplexer_mgr_$listen_mpx entry (char (*), fixed bin (35));
dcl  multiplexer_mgr_$stop_mpx entry (char (*), fixed bin (35));
dcl  multiplexer_mgr_$shutdown_mpx_command entry (character (*), bit (1) aligned, fixed binary (35));
dcl  datebin_$next_shift_change entry (fixed bin (71), fixed bin (71), fixed bin, fixed bin);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  get_process_id_ entry () returns (bit (36));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hphcs_$ips_wakeup entry (bit (36) aligned, char (*));
dcl  ioa_$rsnnl entry options (variable);
dcl  ioa_$rs entry options (variable);
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
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  load_ctl_$set_maxunits entry (fixed bin);
dcl  load_ctl_$set_abs_parms entry;
dcl  mc_check_access_$log_daemon_in entry (pointer, character (*), fixed binary (35));
dcl  ssu_$get_info_ptr entry (pointer) returns (pointer);
dcl  sys_log entry variable options (variable) init (sys_log_$command);
dcl  sys_log$error_log entry variable options (variable) init (sys_log_$command_error);
dcl  (sys_log_, sys_log_$error_log, sys_log_$command, sys_log_$command_error)
	external entry;
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  rcp_list entry;
dcl  rcp_cancel entry;
dcl  match_star_name_ entry (char (*), char (*), fixed bin (35));
dcl  match_request_id_ entry (fixed bin (71), char (*)) returns (bit (1) aligned);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  list_abs_requests$abs_list entry (ptr, fixed bin, fixed bin (71), fixed bin); /* last arg is NOT fixed bin (35) */
dcl  cancel_abs_request$as_abs entry (ptr, fixed bin, fixed bin (71), fixed bin (35));

/* External */
dcl  as_error_table_$try_again_at_msg fixed bin (35) ext;
dcl  as_error_table_$special_sess_msg fixed bin (35) ext;
dcl  as_error_table_$sys_down_msg fixed bin (35) ext;
dcl  error_table_$action_not_performed fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$noentry fixed bin (35) ext static;

/* Builtin */

dcl  (addr, after, before, clock, divide, hbound, index, length, max,
     min, null, rtrim, substr, sum, unspec, verify) builtin;


/* Internal Static */

dcl  goingdown bit (1) int static init ("0"b);		/* TRUE if auto shutdown scheduled */
dcl  auto_bump_chn fixed bin (71) int static;		/* channel for auto shutdown */
dcl  stopflag bit (1) aligned init ("0"b) int static;	/* TURE once operator has typed stop */
dcl  abs_stop_chn int static fixed bin (71);		/* event channel associated with shutting down abs */
dcl  absolute_max_queue fixed bin int static init (4);	/* maximum number of queues */
dcl  abs_shut_interval fixed bin int static init (1800);	/* 30 minutes between shutdown and abs stop */
dcl  abs_shut_offset fixed bin int static init (600);	/* allow abs to run for 10 mins after interactives out */
dcl  saved_max_abs_users fixed bin (17) internal static;
dcl  saved_abs_maxu_auto bit (1) aligned internal static;

/* Constant */

dcl  DIGITS char (10) int static init ("0123456789") options (constant); /* for checking time. */
dcl  ME char (6) int static init ("admin_") options (constant);
dcl  MILLION fixed bin (35) int static init (1000000) options (constant); /* useful constant */
dcl  NL char (1) internal static options (constant) init ("
");
dcl  ONE_WEEK fixed bin (71) int static init (604800000000) options (constant); /* microseconds in a week */
dcl  SECS_IN_MIN fixed bin int static init (60) options (constant); /* seconds in a minute */
dcl  n_called fixed bin int static;			/* accumulative time from which stop absentee issued */
dcl  abs_command (16) char (12) int static options (constant) initial
	("maxu", "maxq", "stop", "start", "bump", "cancel", "qres", "cpu_limit",
	"defer", "list", "move", "next", "release", "run", "suspend",
	"terminate"
	);

dcl  four_zeros (4) fixed bin int static options (constant) init ((4) 0);
dcl  CAPITALS char (26) int static options (constant) init
	("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

/* Automatic */

dcl  code fixed bin (35);
dcl  (i, j, k, l, strl) fixed bin;			/* temps */
dcl  lng fixed bin (21);
dcl  temp_sw bit (1) aligned;
dcl  (clock_value, saveclk) fixed bin (71);		/* clock readings in microseconds */
dcl  prefix char (200) aligned;			/* message for user */
dcl  shortinfo char (8) aligned, (longinfo, longinfo1) char (100) aligned;
dcl  comname char (24);
dcl  msg char (80);					/* message */
dcl  (day_now, day_back) char (6);			/* dates */
dcl  reason char (124);				/* reason for next shutdown */
dcl  string char (256);				/* string of arguments */
dcl  (wpers, wproj) char (28) init ("");		/* person and proj id to look for */
dcl  answer char (256) init ("");			/* message typed to operator */
dcl  arg_count fixed bin;				/* set in validate */
dcl  arg_list_ptr ptr;				/* pointer to our argument list */
dcl  p ptr;					/* junk ptr */
dcl  action_flag bit (1) aligned;
dcl  abs_funct char (12);				/* function to be performed by absentee commands */
dcl  mess char (8);					/* event message for use by absentee commands */
dcl  ev_p ptr;					/* pointer to above */
dcl  temp char (2);					/* abs q number */
dcl  source char (8),				/* Source name, used in "route" */
     attchan char (32);				/* .. channel ID or file name */
dcl  (check_sw, force_sw, go_sw) bit (1) aligned;
dcl  qres (4) fixed bin;
dcl  mpx_name char (32);				/* name of a mltiplexer */
dcl  fnp_only bit (1) init ("0"b);			/* set if one of obsolete fnp only commands called */
dcl  nargs fixed bin;
dcl  abs_start_at_startup bit (1) aligned;
dcl  fb71 fixed bin (71);				/* temp */
dcl  b12 bit (12);
dcl  c4 char (4);
dcl  temp_dir char (168);
dcl  temp_ename char (32);
dcl  abs_arg_ptr ptr;
dcl  continue bit (1) aligned;
dcl  error_message char (256);			/* text of error message */

/* Based */

dcl  1 auto_abs_args like abs_args aligned;
dcl  arg char (lng) based (p);			/* pickup structure for arguments */
dcl  bf fixed binary (71) based (p);			/* for event message */
dcl  1 xmessage aligned based (ev_p),			/* structure which describes a two part */
       2 string char (4) aligned,			/* event message sent to absentee user manager */
       2 table_index fixed bin;			/* index in AUT */

dcl  based_anstbl_message char (lng) based (addr (anstbl.special_message));
%page;
login: entry options (variable);

/* *** This entry implements the operator "login" command.  It allows
   the operator to log in system daemons. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: login";

	call validate;				/* locate anwer table */
	if arg_count = 0 then
LOGIN_USAGE:   do;
	     answer = "Usage: login Person.Project SOURCE {-control_args}";
	     go to admin_answers;
	end;


	call get_pers_proj (arg_list_ptr, 1, i, code);	/* get person, project */
	if code ^= 0 then go to LOGIN_USAGE;

	call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr); /* see if source arg */
	if code ^= 0 then go to LOGIN_USAGE;
	attchan = arg;

	sc_subsystem_info_ptr = ssu_$get_info_ptr (sc_stat_$admin_sci_ptr);
	call mc_check_access_$log_daemon_in (sc_subsystem_info_ptr, attchan, code);
	if code ^= 0 then do;
	     if code = error_table_$noentry
	     then answer = "No MC ACS segment for the source " || rtrim (attchan) || ".";
	     else answer = "Login not permitted for message coordinator source " || rtrim (attchan) || ".";
	     go to admin_err;
	end;

	i = i + 1;				/* get next arg */
	call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr); /* See if optional args. */
	if code ^= 0 then string = "";
	else call build_string (arg_list_ptr, (i));	/* we don't need i any more, but build_string does */

	call daemon_user_manager_$login (wpers, wproj, attchan, string);
						/* Cause automatic login of daemon */

	return;
%page;
logout: entry options (variable);

/* *** This entry implements the operator "logout" command.  It allows
   an operator to logout system daemons. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: logout";

	call validate;				/* locate answer table */

	call get_pers_proj (arg_list_ptr, 1, i, code);	/* get person, project, set i */
	if code ^= 0 then do;
	     answer = "Usage: logout Person.Project {SOURCE}";
	     go to admin_answers;
	end;

	call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr); /* get source */
	if code ^= 0 then source = "*";
	else source = arg;
	call daemon_user_manager_$logout (wpers, wproj, source); /* bop */

	return;
%page;
word: entry options (variable);

/* *** This entry implements the operator "word" command.  It allows the
   operator to set the login word. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: word";
	call cu_$generate_call (SET_LOGIN_WORD, cu_$arg_list_ptr ());
	return;
%page;
sysid: entry options (variable);

/* *** This entry implements the operator "sysid" command.  It allows
   the operator to set the published system id in the who table. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: sysid";

	call validate;				/* locate answer table */

	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr); /* get system id argument */
	if code ^= 0 then go to admin_err;
	if whoptr = null then return;			/* in case trouble */
	whotab.sysid = arg;				/* change public system id */
	return;
%page;
down1: entry (dn_time, dn_msg, dn_until);

/* *** This entry is called by as_init_ to restore an old scheduled
   shutdown. */

dcl  (dn_time, dn_until) fixed bin (71), dn_msg char (*);

	arg_list_ptr = cu_$arg_list_ptr ();
	call validate;
	comname = "admin_: down";
	call SCHEDULE_SYSTEM_SHUTDOWN (dn_time, dn_msg, dn_until);
	return;
%page;
down: entry options (variable);

/* *** This is the operator "down" command.  It schedules a system shutdown,
   stops a scheduled shutdown, or tells the operator when the next
   system shutdown is scheduled. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: down";
	call validate;

	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr); /* get shutdown time */
	if code ^= 0 then do;			/* If no args, tell when shutdown will be. */
	     if ^goingdown then
		call sys_log (SL_LOG, "^a: down: No shutdown is scheduled.", ME);
	     else do;
		msg = date_time_$format ("date_time", whotab.nextsd, "", "");
		answer = date_time_$format ("date_time", whotab.until, "", "");
		call sys_log (SL_LOG, "^a: down: Next shutdown from ^a to ^a ^a", ME, msg, answer, whotab.why);
	     end;
	     return;
	end;

	string = arg;				/* align argument */
	if lng = 1 then
	     if string = "0" then do;			/* if time is 0 then reset previous shutdown command */
		call CANCEL_SYSTEM_SHUTDOWN (answer, code);
		if code ^= 0 then
		     goto admin_answers;
		else return;
	     end;

	if verify (arg, DIGITS) = 0 then
	     call convert_date_to_binary_ (arg || ".", saveclk, code);
	else call convert_date_to_binary_ (arg, saveclk, code);
	if code ^= 0 then do;			/* Check if time is legal. */
bad_t:	     answer = arg || " invalid clock time.";
	     go to admin_answers;
	end;

	if saveclk < clock () then go to bad_t;		/* Silly. We passed that. */

	j = 3;					/* arg. position */
	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr); /* Next uptime, message, or nothing */
	if code ^= 0 then do;
	     clock_value = 0;			/* default time up */
	     reason = " ";				/* default reason */
	end;
	else do;
	     if verify (arg, DIGITS) = 0 then
		call convert_date_to_binary_ (arg || ".", clock_value,
		     code);
	     else call convert_date_to_binary_ (arg, clock_value, code);
	     if code ^= 0 then do;			/* Must be a message, not time. */
		clock_value = 0;			/* default up time */
		go to why;			/* assign message */
	     end;
	     if clock_value < saveclk then do;
		answer = "uptime is earlier than downtime.";
		go to admin_answers;
	     end;

	     j = 4;				/* arg. pos */
	     call cu_$arg_ptr_rel (3, p, lng, code, arg_list_ptr); /* message, or nothing */
	     if code ^= 0 then reason = " ";		/* default reason */
	     else do;				/* there is a reason */
why:		call build_string (arg_list_ptr, j - 1);
		reason = substr (string, 1, strl);
	     end;
	end;

	if goingdown then do;			/* already a shutdown? */
	     msg = date_time_$format ("date_time", whotab.nextsd, "", "");
	     call sys_log (SL_LOG, "^a: down: resetting previous shutdown at ^a", ME, msg);
	     call CANCEL_SYSTEM_SHUTDOWN (answer, (0));
	end;

	call SCHEDULE_SYSTEM_SHUTDOWN (saveclk, reason, clock_value);
	return;
%page;
stop: entry options (variable);

/* *** This is the operator "stop" command.  It allows a graceful shutdown
   of the system by bumping all the users with grace time. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: stop";
	call validate;				/* locate answer table */
	call cu_$arg_count_rel (i, arg_list_ptr, (0));	/* operators keep typing "stop absentee" ... */
	if i > 0 then do;				/* .. so reject this */
	     answer = "no arguments are allowed for ""stop""";
	     go to admin_answers;			/* .. try again, dummy */
	end;

	call stop_command;				/* do the work */
	return;					/* that was easy... */
%page;
timed_stop_command:
     entry;

/* *** This entry is called as a result of an alarm timer set by the "down"
   command.  It allows the system to shut down in an orderly fashion */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: stop";
	call set_non_command_sys_loggers;
	call sys_log (SL_LOG, "^a: stop: Automatic shutdown", ME); /* and fix all up */
	call validate;				/* going to need answer table */
	call stop_command;				/* now bump everybody */
	return;
%page;
/* format: style5,ind5 */

warn:
     entry options (variable);

/* *** This entry implements the operator "warn" command.  It allows the
   operator to blast a message on a user's terminal. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: warn";
	call validate;			      /* locate answer table */

	call get_pers_proj (arg_list_ptr, 1, i, code);/* get person, project, set i */
	if code ^= 0 then
	     do;
	     answer = "Usage: warn Person.Project MESSAGE";
	     go to admin_answers;
	     end;

	call build_string (arg_list_ptr, i);	      /* get message to be sent to user */

	action_flag = "0"b;			      /* haven't done anybody yet */

	continue = "1"b;
	do i = 1 to anstbl.current_size while (continue);
	     utep = addr (anstbl.entry (i));	      /* get ptr to a user entry */
	     if ute.active >= NOW_LOGGED_IN then      /* if user logged in */
		do;
		if wpers = "*" | wpers = ute.person then
		     if wproj = "*" | wproj = ute.project then
			do;
			action_flag = "1"b;	      /* did something */
			if ^ute.uflags.disconnected then
			     do;
			     call asu_$blast_user (utep, string,
			         error_message, code);
			     if code ^= 0 then
				call sys_log (SL_LOG, "^a: warn: ^a",
				    ME, error_message);
			     end;
			if wpers ^= "*" & wproj ^= "*" then
			     continue = "0"b;     /* no more searching */
			end;
		end;
	end;

	if ^action_flag then
	     call sys_log (SL_LOG, "^a: warn: ^a.^a not found.", ME, wpers,
	         wproj);
	return;
%page;

/* format: style4 */

rcp: entry options (variable);

/* *** This is the operator "rcp" command.  It forwards the call to the
   appropriate rcp command: rcp_list or rcp_cancel. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: rcp";

	call validate;				/* locate answer table */
	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr); /* get opcode, or index */
	if code ^= 0 then goto admin_err;
	if arg = "list" then
	     call cu_$generate_call (rcp_list, cu_$arg_list_ptr ());
	else if arg = "cancel" then
	     call cu_$generate_call (rcp_cancel, cu_$arg_list_ptr ());
	else do;
	     answer = "unknown rcp command " || arg;
	     goto admin_answers;
	end;

	return;
%page;
log: entry options (variable);

/* *** This is the operator "log" command.  It allows the operator to
   place an entry in the answering service log. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: log";

	call build_string (arg_list_ptr, 1);		/* make up a string which is the comment */
	call sys_log (SL_LOG_SILENT, "^a: log: ^a", ME, string); /* write off line */
	return;
%page;
maxunits:
     entry options (variable);

/* *** This is the "maxu" operator command.  It allows the operator to set
   the maximum number of load units allowed on the system. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: maxunits";

	call validate;				/* locate answer table */
	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr); /* get first arg */
	if code ^= 0 then do;			/* if no argument given, print current maxu */
	     call sys_log (SL_LOG, "^a: maxu: ^[^; (auto)^; (level)^]: ^d (^d normal users)",
		ME, anstbl.auto_maxu + 1, anstbl.max_units, divide (anstbl.max_units, 10, 17, 0));
	     return;
	end;
	string = arg;				/* get maxunits */
	if string = "auto" then do;			/* turn on auto setting of max */
	     anstbl.auto_maxu = 1;			/* whee */
	     call load_ctl_$set_maxunits (anstbl.shift);	/* stimulate */
	end;
	else if string = "level" then do;		/* make adjustment of max be dynamic */
	     anstbl.auto_maxu = 2;			/* whee wheee */
	     call load_ctl_$set_maxunits (anstbl.shift);	/* and poke it once */
	end;
	else do;
	     i = cv_dec_check_ (string, code);		/* want to shut off automatic thing and force it */
	     if code ^= 0 then go to wrong_maxunits;
	     if i <= 0 then do;			/* simple checks */
wrong_maxunits:
		answer = arg || " is invalid value for maxunits";
		go to admin_answers;
	     end;
	     if i < 200 then			/* check for a likely mistake */
		call sys_log (SL_LOG, "^a: maxu: Warning: maxunits are in tenths of load units.^/^-You just set maxu to ^d, or ^d normal users.",
		     ME, i, divide (i, 10, 17, 0));
	     anstbl.max_units = i;			/* set the system max load units. */
	     anstbl.auto_maxu = 0;			/* Turn off automatic adjustment */
	     whotab.mxunits = i;			/* tell users too */
	end;
	call sys_log (SL_LOG, "^a: maxu^[^; (auto)^; (level)^]: ^d (^d normal users)",
	     ME, anstbl.auto_maxu + 1, anstbl.max_units, divide (anstbl.max_units, 10, 17, 0));

	return;
%page;
/* ADMIN_$SHIFT  - Override shift table - set specified shift until specified time.

   Usage:
   shift		prints "shift S until T"
   shift auto	resets to shift given in shift table
   shift S	sets shift to S until next regular shift change time
   shift S T	sets shift to S until time T (T < one week in future)

*/

shift: entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "admin_: shift";

	call validate;				/* get ptrs to various tables */
	clock_value = clock ();			/* use same clock value throughout execution of command */
	j = -1;					/* do not log the command unless we change something */

	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr); /* see if there is at least one argument */
	if code = 0 then do;			/* there is */
	     string = arg;				/* align the argument */

	     if string = "auto" then do;		/* revert to using shift table */
		whotab.next_shift_change_time = 0;	/* force datebin_ to look in shift table */
		call datebin_$next_shift_change (clock_value, whotab.next_shift_change_time, whotab.shift, (0));
	     end;

	     else do;				/* first arg must be shift number */
		i = cv_dec_check_ (string, code);
		if code ^= 0 | i < 0 | i > 7 then do;
		     answer = arg || " is not a legal shift number.";
		     goto admin_answers;
		end;

		call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr); /* see if time has also been given */
		if code = 0 then do;		/* it has */
		     if verify (arg, DIGITS) = 0 then
			call convert_date_to_binary_ (arg || ".", saveclk, code);
		     else call convert_date_to_binary_ (arg, saveclk, code);
		     if code ^= 0 then do;
			answer = arg || " invalid clock time.";
			goto admin_answers;
		     end;

		     if saveclk <= clock_value | saveclk > clock_value + ONE_WEEK then do;
			answer = arg || " is not within the next week.";
			goto admin_answers;
		     end;

		     whotab.next_shift_change_time = saveclk;
		end;				/* end of time-given do group */

		whotab.shift = i;			/* we waited to see if time was ok before changing shift */
	     end;					/* end of shift-given do group */
	     j = 1;				/* we changed something, so log the command */
	end;					/* end of first-arg-given do group */

	msg = date_time_$format ("date_time", whotab.next_shift_change_time, "", "");
	call sys_log (SL_LOG, "admin_: shift: ^d until ^a", whotab.shift, msg); /* print shift and time on opr cons */

	if anstbl.shift ^= whotab.shift then do;	/* only if shift actually changed */
	     whotab.last_shift_change_time = clock_value; /* remember when it did */
	     call act_ctl_$shift_cmnd_update;		/* tell accounting to use new rates */
	end;

	return;
%page;
/* The following four entry points deal with FNPs. They allow the operator to
   perform manually some functions that are usually performed automatically by the answering service.
   These commands are provided for debugging and reconfiguration purposes,
   and should not have to be used during normal system operation. */

/* ADMIN_$FDUMP_FNP = CALL SUBROUTINE TO DUMP A SPECIFIED FNP */
/* ADMIN_$DUMP_FNP = CALL SUBROUTINE TO DUMP A SPECIFIED FNP */
/* ADMIN_$DUMP_MPX = CALL SUBROUTINE TO DUMP A SPECIFIED MULTIPLEXER */

fdump_fnp:
     entry options (variable);
dump_fnp:
     entry options (variable);

	fnp_only = "1"b;
	comname = "admin_: fdump_fnp";

dump_mpx:
     entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();
	if ^fnp_only then
	     comname = "admin_: dump_mpx";

	call validate;

	call get_mpx_name (1);			/* first arg should be multiplexer name */

	force_sw = "0"b;
	code = 0;
	do i = 2 by 1 while (code = 0);		/* check rest of args */
	     call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr);
	     if code = 0 then
		do;
		if arg = "-force" then
		     force_sw = "1"b;
		else
		     do;
		     answer = "unknown argument " || arg;
		     go to admin_answers;
		end;
	     end;
	end;

	call multiplexer_mgr_$dump_mpx (mpx_name, force_sw, code);
	return;

/* ================================================= */

/* ADMIN_$LOAD_FNP = INITIATE A BOOTLOAD OF THE SPECIFIED FNP */
/* ADMIN_$LOAD_MPX = INITIATE A LOAD OF THE SPECIFIED MULTIPLEXER */

load_fnp:
     entry options (variable);

	fnp_only = "1"b;
	comname = "admin_: load_fnp";

load_mpx:
     entry options (variable);			/* new, general command */

	arg_list_ptr = cu_$arg_list_ptr ();

	if ^fnp_only then
	     comname = "admin_: load_mpx";

	call validate;

	call get_mpx_name (1);			/* arg 1 is mpx name */

/* Look for additional arguments */

	check_sw, force_sw = ""b;			/* defaults, if no more args given */
	go_sw = "1"b;
	code = 0;					/* to get past the "while" */

	do i = 2 by 1 while (code = 0);
	     call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr);
	     if code = 0 then
		do;				/* if there is an arg */
		if arg = "-ck" | arg = "-check" then
		     check_sw = "1"b;
		else if arg = "-ns" | arg = "-no_start" | arg = "-nostart"
		then
		     go_sw = ""b;
		else if arg = "-force" then
		     force_sw = "1"b;
		else
		     do;
		     answer = "unknown argument " || arg;
		     goto admin_answers;
		end;
	     end;
	end;

	call multiplexer_mgr_$load_mpx (mpx_name, check_sw, go_sw, force_sw,
	     code);

	return;

/* ================================================= */

/* ADMIN_$START_FNP = LISTEN TO THE PHONES CONFIGURED ON A SPECIFIED FNP */
/* ADMIN_$START_MPX = LISTEN TO THE PHONES CONFIGURED ON A SPECIFIED MULTIPLEXER */

start_fnp:
     entry options (variable);

	fnp_only = "1"b;
	comname = "admin_: start_fnp";

start_mpx:
     entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();

	if ^fnp_only then
	     comname = "admin_: start_mpx";

	call validate;

	call get_mpx_name (1);			/* arg 1 should be the multiplexer name */

	call multiplexer_mgr_$start_mpx (mpx_name, "0"b, code);
	if code ^= 0 then
	     return;

	call multiplexer_mgr_$listen_mpx (mpx_name, code);
	return;

/* ================================================= */

/* ADMIN_$STOP_FNP = PREVENT LOADING, OR LISTENING TO THE PHONES OF, OR ACCEPTANCE OF CALLS BY, THE SPECIFIED FNP */
/* ADMIN_$STOP_MPX = PREVENT LOADING, OR LISTENING TO THE PHONES OF, OR ACCEPTANCE OF CALLS BY, THE SPECIFIED MULTIPLEXER */

stop_fnp:
     entry options (variable);

	fnp_only = "1"b;
	comname = "admin_: stop_fnp";

stop_mpx:
     entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();

	if ^fnp_only then
	     comname = "admin_: stop_mpx";

	call validate;

	call get_mpx_name (1);			/* first arg is multiplexer name */

	call multiplexer_mgr_$stop_mpx (mpx_name, code);

	return;

shutdown_mpx:
     entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();

	comname = "admin_: shutdown_mpx";

	call validate;

	call get_mpx_name (1);			/* first arg is multiplexer name */

	force_sw = "0"b;
	code = 0;
	do i = 2 by 1 while (code = 0);		/* check rest of args */
	     call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr);
	     if code = 0 then
		do;
		if arg = "-force" then
		     force_sw = "1"b;
		else
		     do;
		     answer = "unknown argument " || arg;
		     go to admin_answers;
		end;
	     end;
	end;

	call multiplexer_mgr_$shutdown_mpx_command (mpx_name, force_sw, code);

	return;					/* END of FNP commands */

/* ================================================= */

/* ADMIN_$ABS = A SET OF FUNCTIONS PERTAINING TO ABSENTEE FACILITY */

/* admin_$abs - all operator commands which deal with absenteee enter here */
/*           - first argument indicates which absentee function is intended */

admin_$abs_not_a_command_:
     entry options (variable);

	call set_non_command_sys_loggers;
						/* ** fall down here */

abs:
     entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();

	comname = "admin_: abs";

	call validate;				/* locate answer table */

	if autp = null then
	     do;					/* first call? */
	     call hcs_$initiate (sysdir, "absentee_user_table", "", 0, 0,
		autp, code);
	     if autp = null then
		do;
		call sys_log$error_log (SL_LOG, code, "admin_",
		     "^a>absentee_user_table", sysdir);
		return;
	     end;
	end;

	call cu_$arg_count_rel (nargs, arg_list_ptr, code);
						/* several abs commands need the count */
	abs_arg_ptr = addr (auto_abs_args);		/* initialize ptr to arg structure */
	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr);
						/* get actual command */
	if code ^= 0 then
	     go to admin_err;			/* abs differs from other system control cmds */
	abs_funct = p -> arg;			/* copy absentee opr command */
	ev_p = addr (mess);				/* get ptr to ipc-event message */

/* look up absentee operator command in table & go to label associated with it */

	do i = 1 to hbound (abs_command, 1)
	     while (abs_funct ^= abs_command (i));
	end;
	if i > hbound (abs_command, 1) then
	     do;
	     answer = "unknown absentee command " || arg;
	     go to admin_answers;
	end;

	if ^sc_stat_$Multics then
	     if abs_funct ^= "stop" then
		do;
		call ioa_$rsnnl (
		     "The abs ^a command can not be used before answering service startup.",
		     answer, (0), abs_funct);
		goto admin_answers;
	     end;

	comname = "admin_: abs " || abs_funct;
	goto abs_action (i);
%page;
abs_action (3):					/* ABS STOP */
						/* *** graceful shutdown of absentee facility - keeps checking until no
						   absentee processes left */
	if ^sc_stat_$Multics then			/* abs stop before startup means "don't abs start" */
	     autbl.abs_stopped, autbl.abs_up = ""b;	/* clear any garbage from last bootload */
	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr);
						/* see if second arg given */
	if code = 0 then
	     do;
	     if arg = "now" then
		do;				/* "abs stop now" ? */
		n_called = abs_shut_interval + 1;	/* yes. cause all process to get bumped */
		go to abs_s1;
	     end;

	     else if arg = "q" | arg = "queue" then
		do;				/* drop one or all queues */
		if ^sc_stat_$Multics then
		     do;
		     answer =
			"abs stop queue only works after answering service startup"
			;
		     goto admin_answers;
		end;
		call cu_$arg_ptr_rel (3, p, lng, code, arg_list_ptr);
		if code ^= 0 then
		     do;
		     answer = "missing argument: queue to be stopped";
		     goto admin_answers;
		end;
		if arg = "all" then
		     autbl.queue_dropped (*) = "1"b;
		else if arg = "fg" | arg = "foreground" then
		     autbl.queue_dropped (-1) = "1"b;
		else
		     do;
		     i = cv_dec_check_ (arg, code);
		     if code = 0 then
			do;
			if i >= -1 & i <= absolute_max_queue then
			     autbl.queue_dropped (i) = "1"b;
			else
			     code = 1;		/* any nonzero value, to get error msg printed */
		     end;
		     if code ^= 0 then
			do;
			answer = "invalid queue to be stopped: " || arg;
			goto admin_answers;
		     end;
		end;				/* end not all or foreground */
		goto print_dropped_queues;		/* go do a "abs start queue" to show what happened */
	     end;					/* end abs stop queue */

	     else
		do;				/* bad arg. ignore command */
		answer = "unknown argument " || arg;
		go to admin_answers;
	     end;
	end;
	else
	     n_called = 0;				/* wasn't "abs stop now" - wait a while first */

	if autbl.abs_stopped & autbl.abs_up then
	     do;					/* don't stop absentee if in process of going down */
abs_stopping:
	     answer = "absentee stop in progress";
	     go to admin_answers;
	end;

abs_s1:
	if ^autbl.abs_up then
	     do;					/* don't stop absentee if it is not up */
	     autbl.abs_stopped = "1"b;
	     call sys_log (SL_LOG,
		"^a: abs: absentee not up, and will not be started automatically", ME);
	     if ^sc_stat_$Multics then		/* if before startup */
		call absentee_user_manager_$term_aum;
						/* tell him not to start absentee automatically */
	     go to admin_abs_returns;
	end;

	if goingdown then
	     do;
	     call sys_log (SL_LOG, "^a: abs: resetting auto abs stop", ME);
	     call timer_manager_$reset_alarm_wakeup (abs_stop_chn);
	end;
	else
	     call ipc_$create_ev_chn (abs_stop_chn, code);

	call START_ABSENTEE_SHUTDOWN ();
	return;
%page;
absentee_off:
     entry ();

/* *** This entry is called automatically every 30 seconds once an
   absentee shutdown has been started if there are remaining absentee
   processes running to await their logging out. */

	arg_list_ptr = cu_$arg_list_ptr ();
	call set_non_command_sys_loggers;
	comname = "admin_: abs stop";
	call validate;
	n_called = n_called + 30;			/* keep track of time since abs shutdown performed */
	call CHECK_FOR_ABSENTEE_SHUTDOWN ();		/* Done yet? */
	return;
%page;
absentee_down:
     entry ();

/* *** This entry is called automatically by a timer wakeup when the
   absentee facility is supposed to begin shutdown. The "down"
   command schedules this absentee shutdown. */

	arg_list_ptr = cu_$arg_list_ptr ();
	call set_non_command_sys_loggers ();
	comname = "admin_: abs stop";
	call validate;

	if (^autbl.abs_up | autbl.abs_stopped) then	/* do nothing if not up or already stopped */
	     call absentee_user_manager_$update_whotab_abs_control ();
	else
	     do;
               n_called = 0;
	     call sys_log (SL_LOG, "^a: stop: auto abs stop", ME);
	     call START_ABSENTEE_SHUTDOWN ();
	end;
	return;
%page;
/* The bump, cancel, terminate, suspend, and release functions of the abs
   command share common code. They all take the same set of arguments, and
   they all operate by sending a wakeup  to AUM, with the AUT index in one
   word, and a 4 letter abbreviation of the command name in the other. The
   cancel and release functions can also operate on non-running jobs, so they
   call entry points in AU instead of, or in addition to, sending the wakeup,
   depending on the arguments given. */

/* bumps absentee users - by name, project, absentee id - leaves restartable
   requests in message segment */

/* ********** abs bump ********** */

abs_action (5):					/* ABS BUMP */
	ev_p -> xmessage.string = "bump";
	go to abs_bump_common;

/* bumps absentee users - by name, project, absentee id - deletes restartable requests from message segment */

/* ********** abs cancel ********** */

abs_action (6):					/* ABS CANCEL */
	ev_p -> xmessage.string = "canc";
	goto abs_bump_common;

/* ********** abs release ********** */

abs_action (13):
	ev_p -> xmessage.string = "rlse";
	goto abs_bump_common;

/* ********** abs suspend ********** */

abs_action (15):
	ev_p -> xmessage.string = "susp";
	goto abs_bump_common;

/* ********** abs terminate ********** */

abs_action (16):
	ev_p -> xmessage.string = "term";
	goto abs_bump_common;


abs_bump_common:
	if ^autbl.abs_up then
	     goto abs_not_up;
	k = 0;					/* clear counter of selected jobs */

	call parse_abs_args (arg_list_ptr);		/* look at job selection args and fill in structure */
	if abs_funct = "cancel" then			/* abs cancel must give user name and not "*" */
	     call validate_abs_args ("1"b, "1"b);	/* allow absN, require user */
	else
	     call validate_abs_args ("1"b, "0"b);	/* allow absN, don't require user */

	if abs_funct ^= "cancel" | abs_args.absn_sw | abs_args.abs_star_sw
	then
	     do;					/* scan AUT unless cancel &^absN */
	     if abs_args.absn_sw then
		i, j = abs_args.aut_index;		/* if absN, just look at slot N */
	     else
		do;
		i = 1;
		j = autbl.current_size;
	     end;

	     do i = i to j;
		utep = addr (autbl.entry (i));
		if ute.active < NOW_LOGGED_IN then
		     if abs_args.absn_sw then
			do;
			call ioa_$rsnnl (
			     "No job in absentee slot ^d (status= ^d).",
			     answer, (0), i, ute.active);
			goto admin_answers;
		     end;
		     else
			goto abs_bump_nomatch;

		if abs_args.user_sw then
		     if (abs_args.person ^= "*"
			& abs_args.person ^= ute.person)
			| (abs_args.project ^= "*"
			& abs_args.project ^= ute.project) then
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d is not from user ^a.^a",
				answer, (0), i, abs_args.person,
				abs_args.project);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;

		if abs_args.id_sw then
		     if ^match_request_id_ (ute.request_id,
			(abs_args.request_id_string)) then
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d does not match request ID ^a",
				answer, (0), i,
				abs_args.request_id_string);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;

		if abs_args.path_sw | abs_args.entry_sw then
		     do;
		     call expand_pathname_ (ute.input_seg, temp_dir,
			temp_ename, (0));
		     call match_star_name_ (temp_ename, abs_args.ename,
			code);
		     if code ^= 0
			| (abs_args.path_sw & temp_dir ^= abs_args.dirname)
		     then
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d does not match absin ^[path ^a>^a^;entry name ^s^a^]",
				answer, (0), i, abs_args.path_sw,
				abs_args.dirname, abs_args.ename);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;
		end;

		if abs_args.sender_sw then
		     do;
		     call match_star_name_ (ute.sender, abs_args.sender,
			code);
		     if code ^= 0 then
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d is not from sender ^a",
				answer, (0), i, abs_args.sender);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;
		end;

		if abs_args.queue_sw then
		     if (abs_args.queue > 0 & ute.queue ^= abs_args.queue)
			| (abs_args.queue = 0
			& (ute.queue ^= 1 | ^ute.adjust_abs_q_no))
			| (abs_args.queue = -1 & ^ute.foreground_job) then
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d is not from queue ^d",
				answer, (0), i, abs_args.queue);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;

		if abs_funct = "release" then		/* if release */
		     if ^ute.sus_sent then		/* and job not suspended */
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d is not suspended.",
				answer, (0), i);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;

		if abs_funct = "suspend" then		/* if suspend */
		     if ute.sus_sent then		/* and job already suspended */
			if abs_args.absn_sw then
			     do;
			     call ioa_$rsnnl (
				"Job in absentee slot ^d is already suspended.",
				answer, (0), i);
			     goto admin_answers;
			end;
			else
			     goto abs_bump_nomatch;

/* This job has been selected. Put AUTBL slot number into message */

		ev_p -> xmessage.table_index = i;

/* Send wakeup to absentee user manager. It contains the slot number and the action to be taken. */

		call hcs_$wakeup (whotab.abs_procid, whotab.abs_event,
		     ev_p -> bf, code);
		k = k + 1;			/* count selected jobs */
abs_bump_nomatch:
	     end;					/* end loop thru aute's */

	     if abs_funct = "release"			/* if release */
		& ^(abs_args.absn_sw | abs_args.abs_star_sw) then
		do;				/* and a running job was not specified,
						   see if we need to release deferred job(s) */
		call absentee_utility_$abs_release (abs_arg_ptr, l);
						/* l is returned count of released jobs */
		if k + l = 0 then
		     do;				/* no jobs released */
		     answer =
			"Selection arguments matched no deferred or suspended absentee requests."
			;
		     goto admin_answers;
		end;
		else if k > 0 then
		     do;				/* one or more suspended jobs were released */
		     call ioa_$rsnnl ("^d suspended request^[s^] released.",
			answer, (0), k, (k ^= 1));
		     goto admin_replies;
		end;
	     end;
	     else
		do;				/* see if scan of AUT found any jobs */
		if autbl.n_abs_run = 0 then
		     do;
		     answer = "There are no absentee jobs running.";
		     goto admin_replies;
		end;
		else if k = 0 then
		     do;
		     answer =
			"Selection arguments matched no running absentee jobs."
			;
		     goto admin_answers;
		end;
	     end;

	end;					/* end ^cancel | absN */

	else
	     do;					/* abs cancel, and not absN */
	     call cancel_abs_request$as_abs (arg_list_ptr, nargs, fb71, code);
	     if code ^= 0 & fb71 ^= 0 then
		do;				/* a running job was cancelled, so we must bump it */
		do i = 1 to autbl.current_size
		     while (addr (autbl.entry (i)) -> ute.request_id ^= fb71)
		     ;
		end;
		if i <= autbl.current_size then
		     do;
		     ev_p -> xmessage.table_index = i;
		     call hcs_$wakeup (whotab.abs_procid, whotab.abs_event,
			ev_p -> bf, code);
		end;
	     end;
	end;
	goto admin_abs_returns;

/* code to initialize the absentee facility */
/* set max abs users */
/* signals absentee user manager so that it will */
/* attempt to login max abs users */

/* ********** abs start ********** */

abs_action (4):					/* ABS START */
	if (autbl.abs_up & autbl.abs_stopped) then
	     do;					/* If absentee is running down */
	     if autbl.n_abs_run > 0 then
		call ABORT_ABSENTEE_SHUTDOWN ();
	     call ipc_$delete_ev_chn (abs_stop_chn, code);
	     call absentee_user_manager_$term_aum;
	     autbl.abs_up, autbl.abs_stopped = ""b;	/* all finished, clear indicators */
	end;
	if goingdown then				/* If an automatic shutdown is scheduled, */
	     if (whotab.nextsd - clock ()) < abs_shut_interval * MILLION then
		do;
		answer = "system coming down soon: no abs start";
		go to admin_answers;
	     end;

	abs_start_at_startup = ""b;			/* gets turned on if "abs start startup" */
	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr);
						/* fetch second argument - max number of absentee users */
	if code ^= 0 then
	     do;					/* if no argument default values for max users + max queue */
	     if autbl.abs_up then
		do;				/* initialization of absentee non-reentrant */
abs_already_up:
		answer = "absentee already up";	/* abs start queue (checked for below) is allowed with abs up */
		go to admin_answers;
	     end;
default_u:
	     autbl.abs_maxu_auto = "1"b;		/* remember to set default maxu later */
default_q:
	     autbl.abs_maxq_auto = "1"b;		/* remember to set default maxq later */
	end;

	else if arg = "queue" | arg = "q" then
	     do;					/* trying to restart a previously dropped queue */
	     call cu_$arg_ptr_rel (3, p, lng, code, arg_list_ptr);
						/* get queue to be restarted */
	     if code ^= 0 then
		do;				/* if no q to restart given, print q status */
		if sum (autbl.qerr) = 0 & unspec (autbl.queue_dropped) = ""b
		then
		     call sys_log (SL_LOG,
			"^a: abs: Zero errors on all absentee queues.", ME);
		else
		     do;
print_dropped_queues:
		     temp_sw = (unspec (autbl.queue_dropped) ^= ""b);
						/* make temp_sw "1"b if any queues dropped */
		     call sys_log (SL_LOG,
			"^a: abs: Queue errors^[^x(*=dropped)^]:", ME, temp_sw);
		     call sys_log (SL_LOG, "^a: abs: FG^2x0^2x1^2x2^2x3^2x4", ME);
		     call sys_log (SL_LOG, "^a: abs:^6(^x^2d^)", ME, autbl.qerr);
		     if temp_sw then
			call sys_log (SL_LOG, "^a: abs:^6(^2x^[*^;^x^]^)",
			     ME, autbl.queue_dropped);
		end;
		goto admin_abs_returns;
	     end;

	     if ^(autbl.abs_up & ^autbl.abs_stopped) then
		do;				/* can only do this when absentee is up */
		answer = "absentee not up. cannot restart queue " || arg;
		goto admin_answers;
	     end;
	     if arg = "all" then
		do;
		autbl.qerr (*) = 0;
		autbl.queue_dropped (*) = ""b;
		goto nudge;
	     end;
	     else if arg = "fg" | arg = "foreground" then
		do;
		code = 0;
		i = -1;
	     end;
	     else
		i = cv_dec_check_ (arg, code);
	     if code = 0 then
		do;
		if i >= -1 & i <= absolute_max_queue then
		     do;
		     autbl.qerr (i) = 0;		/* clear error count for this queue */
		     autbl.queue_dropped (i) = ""b;
		     goto nudge;			/* go send wakeup to see if any jobs waiting to be run */
		end;
		else
		     code = 1;			/* any nonzero value, to get error message printed */
	     end;
	     if code ^= 0 then
		do;
		answer = "invalid queue to be restarted " || arg;
		goto admin_answers;
	     end;
	end;					/* end of abs start queue */

	else
	     do;					/* normal abs start */
	     if autbl.abs_up then
		goto abs_already_up;
	     if arg = "startup" then
		do;				/* if called by load_ctl_ at a.s. startup */
		abs_start_at_startup = "1"b;		/* remember that for later */
		goto default_u;			/* go turn on default switches for maxu and maxq */
	     end;
	     else
		do;
		call abs_maxu (arg);		/* set max users for absentee from value in command line */

		call cu_$arg_ptr_rel (3, p, lng, code, arg_list_ptr);
						/* fetch third argument - highest queue to be searched */
		if code ^= 0 then
		     go to default_q;		/* if no argument set default value in absentee user table */
		call abs_maxq (arg);		/* set max queue to be searched to value from command */
	     end;
	end;

	call absentee_user_manager_$init_aum (code);	/* call initialization entry point */
	if code ^= 0 then
	     go to admin_abs_returns;			/* message already printed */

	autbl.abs_up = "1"b;			/* set indicators correctly */
	autbl.abs_stopped = ""b;
	autbl.qerr (*) = 0;				/* clear per-queue error indicators */
	autbl.queue_dropped (*) = ""b;
	autbl.abs_qres_auto, autbl.abs_cpu_limit_auto = "1"b;
						/* assume defaults for these */

	if ^abs_start_at_startup then			/* if command was "abs start startup", this is a.s. startup */
						/* and we were called from load_ctl_$set_maxunits */
						/* of which load_ctl_$set_abs_parms is an entrypoint */
	     call load_ctl_$set_abs_parms;		/* if not called from load_ctl_, call load_ctl_ */

	if goingdown then				/* if a scheduled shutdown set up timer */
	     call SCHEDULE_ABSENTEE_SHUTDOWN ();

nudge:
	if autbl.max_abs_users > 0 | abs_start_at_startup then
						/* wakeup absentee user manager if slots */
	     call absentee_utility_$au_send_wakeup;
	go to admin_abs_returns;
%page;
abs_action (1):					/* ABS MAXU */
	if ^autbl.abs_up then
	     do;
abs_not_up:
	     answer = "absentee not up";
	     goto admin_answers;
	end;

	if autbl.abs_stopped then
	     goto abs_stopping;

	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr);
						/* get new max. abs. users from command */
	if code ^= 0 then
	     do;					/* if no argument, print current maxu */
	     call sys_log (SL_LOG, "^a: abs: maxu (^[auto^;manual^]): ^d",
		ME, autbl.abs_maxu_auto, autbl.max_abs_users);
	     goto admin_abs_returns;
	end;

	if arg = "auto" then
	     do;
	     autbl.abs_maxu_auto = "1"b;
	     call load_ctl_$set_abs_parms;
	     go to admin_abs_returns;
	end;
	else
	     call abs_maxu (arg);			/* set new value of max abs users */

	goto nudge;
%page;
/* set queue number which is highest queue searched */

/* ********** abs maxq ********** */

abs_action (2):					/* ABS MAXQ */
	if ^autbl.abs_up then
	     go to abs_not_up;
	if autbl.abs_stopped then
	     goto abs_stopping;

	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr);
						/* get new max queue from command */
	if code ^= 0 then
	     do;					/* if no argument, print current maxq */
	     call sys_log (SL_LOG, "^a: abs: maxq (^[auto^;manual^]): ^d",
		ME, autbl.abs_maxq_auto, autbl.last_queue_searched);
	     goto admin_abs_returns;
	end;

	if arg = "auto" then
	     do;
	     autbl.abs_maxq_auto = "1"b;
	     call load_ctl_$set_abs_parms;
	     go to admin_abs_returns;
	end;
	else
	     do;
	     call abs_maxq (arg);			/* set new max queue in absentee user table */
	     go to nudge;
	end;

/* ********** abs qres ********** */

abs_action (7):					/* ABS QRES */
	if ^autbl.abs_up then
	     goto abs_not_up;
	j = 0;					/* clear argument counter */
	qres (*) = 0;				/* default = 0 for any queue whose reservation is not specified */
	code = 0;					/* clear possible garbage, so the while clause always works */

	do i = 2 to 5 while (code = 0);		/* go thru up to 4 arguments */
	     call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr);
	     if code = 0 then
		do;				/* if argument is there */
		qres (i - 1) = cv_dec_check_ (arg, code);
		if code ^= 0 | qres (i) < 0 then
		     do;				/* if not positive decimal number */
		     if arg = "auto" & nargs = 2 then
			;			/* it's ok if it's "auto" */
		     else
			do;			/* but anything else is an error */
			answer = "abs qres has invalid value: " || arg;
			goto admin_answers;
		     end;
		end;
		j = j + 1;			/* count valid arguments */
	     end;
	end;

	if nargs = 1 then				/* no args means print current values */
	     call sys_log (SL_LOG, "^a: abs: qres ^[^2x(auto)^;(manual)^]:^4(^x^2d^)",
		ME, autbl.abs_qres_auto, autbl.qres);
	else if arg = "auto" then
	     do;
	     autbl.abs_qres_auto = "1"b;
	     call load_ctl_$set_abs_parms;
	end;

	else
	     do;
	     autbl.abs_qres_auto = ""b;
	     autbl.qres (*) = qres (*);		/* copy them all, setting unspecified ones to zero */
	end;
	do i = 1 to 4;				/* compute the resulting limits */
	     qres (i) =
		available_slots_ (i, autbl.max_abs_users, (autbl.qres),
		four_zeros);
	end;
	call sys_log (SL_LOG, "^a: abs: queue^2xlimits:^4(^x^2d^)",
	     ME, qres);				/* and print them */
	if nargs > 1 then
	     if arg ^= "auto" then
		goto nudge;
	goto admin_abs_returns;

/* ********** abs cpu_limit ********** */

abs_action (8):					/* cpu_limit */
	if ^autbl.abs_up then
	     goto abs_not_up;
	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr);
	if code ^= 0 then				/* no arg means print current values */
	     call sys_log (SL_LOG,
		"^a: abs: cpu_limit (^[auto^;manual^]), queues 1-4: ^d^3(,^d^) (seconds)",
		ME, autbl.abs_cpu_limit_auto, autbl.cpu_limit);

	else if arg = "auto" then
	     do;
	     autbl.abs_cpu_limit_auto = "1"b;
	     call load_ctl_$set_abs_parms;
	end;

	else
	     do;
	     if nargs ^= 2 | verify (arg, "0123456789,") ^= 0 then
		do;
		answer =
		     "Usage is: ""abs cpu_limit l1,l2,l3,l4"" (limits in seconds)";
		goto admin_answers;
	     end;

	     i = 1;				/* start at char 1 of limit string */
	     do k = 1 to 4 while (i <= lng);		/* look for limits for 4 queues */
		j = index (substr (arg, i), ",");	/* find next comma */
		if j = 0 then
		     j = lng - i + 2;		/* if none, pretend one after end of string */
		if j > 1 then			/* if not adjacent commas, convert and store the value */
		     autbl.cpu_limit (k) =
			cv_dec_check_ (substr (arg, i, j - 1), (0));
		i = i + j;			/* move past the comma */
		if autbl.cpu_limit (k) < 60 then	/* check for a likely mistake */
		     call sys_log (SL_LOG,
			"^a: abs: Warning: cpu limits are in seconds. You just set queue ^d limit to ^d seconds.",
			ME, k, autbl.cpu_limit (k));
	     end;
	     autbl.abs_cpu_limit_auto = ""b;		/* remember it's set by operator */
	end;

	if nargs = 2 then
	     if arg ^= "auto" then
		goto nudge;
	goto admin_abs_returns;

/* ********** abs defer ********** */

abs_action (9):					/* defer */
	if ^autbl.abs_up then
	     goto abs_not_up;
	call parse_abs_args (arg_list_ptr);
	call validate_abs_args ("0"b, "0"b);		/* reject absN, don't require user */
	call absentee_utility_$abs_defer (abs_arg_ptr);
	goto admin_abs_returns;

/* ********** abs list ********** */

abs_action (10):					/* list */
						/* abs list works when absentee is not up */
	do j = 2 to nargs;				/* look for absN */
	     call cu_$arg_ptr_rel (j, p, lng, code, arg_list_ptr);
	     if code = 0 then
		do;
		if substr (arg, 1, 3) = "abs"
		     & verify (substr (arg, 4), "0123456789") = 0 then
		     do;				/* absN */
		     if ^autbl.abs_up then
			do;
			answer =
			     "The absN argument cannot be used when absentee is not up.";
			goto admin_answers;
		     end;
		     temp = substr (arg, 4);		/* align N */
		     j = cv_dec_check_ (temp, (0));
		     if j > autbl.current_size then
			do;			/* if N is too large, don't try to reference slot N */
			call ioa_$rsnnl ("No job in absentee slot ^d.",
			     answer, (0), j);
			goto admin_answers;
		     end;
		     utep = addr (autbl.entry (j));
		     if ute.active ^= NOW_HAS_PROCESS then
			do;
			call ioa_$rsnnl (
			     "No job in absentee slot ^d (status= ^d).",
			     answer, (0), j, ute.active);
			goto admin_answers;
		     end;
		     if ute.foreground_job then
			i = -1;
		     else if ute.adjust_abs_q_no then
			i = ute.queue - 1;
		     else
			i = ute.queue;
		     fb71 = ute.request_id;
		     j = nargs;			/* get out of the loop */
		end;
	     end;
	end;
	call list_abs_requests$abs_list (arg_list_ptr, nargs, fb71, i);
	goto admin_abs_returns;

/* ********** abs move ********** */

abs_action (11):					/* move */
						/* abs move works when absentee is not up */
	call cancel_abs_request$as_abs (arg_list_ptr, nargs, fb71, code);
	goto admin_abs_returns;

/* ********** abs next ********** */

abs_action (12):					/* next */
						/* abs next works when absentee is not up */
	call cancel_abs_request$as_abs (arg_list_ptr, nargs, fb71, code);
	goto admin_abs_returns;

/* ********** abs run ********** */

abs_action (14):					/* run */
	if ^autbl.abs_up then
	     goto abs_not_up;
	call parse_abs_args (arg_list_ptr);
	call validate_abs_args ("0"b, "1"b);		/* reject absN, require user */
	call absentee_user_manager_$aum_abs_run (abs_arg_ptr);
	goto admin_abs_returns;


/* ================================================= */

admin_err:
	call sys_log$error_log (SL_LOG, code, comname, answer);
	return;

admin_answers:
	call sys_log (SL_LOG, "^a: error: ^a", comname, answer);
	return;

admin_abs_returns:
	call absentee_user_manager_$update_whotab_abs_control;
	return;

admin_replies:					/* reply without saying "error:" */
	call sys_log (SL_LOG, "^a: ^a", comname, answer);
	return;					/* almost all entries exit here */
%page;
/* Internal Procedures */

get_mpx_name:
     proc (argno);

dcl  argno fixed bin;

	call cu_$arg_ptr_rel (argno, p, lng, code, arg_list_ptr);
	if code ^= 0 then
	     do;
	     if fnp_only then
		answer = "No FNP tag specified";
	     else
		answer = "No multiplexer specified";
	     go to admin_answers;
	end;

	mpx_name = arg;
	if fnp_only then
	     do;					/* extra checks to be compatable with old commands */
	     if length (rtrim (mpx_name)) > 1 then
		do;
bad_mpx_fnp_name:
		answer = "Invalid FNP tag: " || mpx_name;
		go to admin_answers;
	     end;
	     if index ("abcdefgh", substr (mpx_name, 1, 1)) = 0 then
		go to bad_mpx_fnp_name;
	end;

	return;

     end get_mpx_name;


/* ****************************************************************************************************************** */


validate:
     proc;

	if ^sc_stat_$Multics_typed then
	     as_data_$sysdir = sc_stat_$sysdir;
	if as_data_$ansp = null then
	     do;
	     call hcs_$initiate (sysdir, "answer_table", "", 0, 0, as_data_$ansp, code);
	     as_procid = get_process_id_ ();
	     if as_data_$ansp = null then
		do;
		call sys_log$error_log (SL_LOG_BEEP, code, ME,
		     "^a>answer_table", sysdir);
		return;
	     end;
	end;
	ansp = as_data_$ansp;
	autp = as_data_$autp;
	dutp = as_data_$dutp;

	if whoptr = null then
	     do;
	     call hcs_$initiate (sysdir, "whotab", "", 0, 0, whoptr, code);
	     if whoptr = null then
		call sys_log$error_log (SL_LOG_BEEP, code, ME, "^a>whotab",
		     sysdir);
	end;
	if ip = null then
	     do;
	     call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, code);
	     if ip = null then
		call sys_log$error_log (SL_LOG_BEEP, code, ME,
		     "^a>installation_parms", sysdir);
	end;
	if scdtp = null then
	     do;
	     call hcs_$initiate (sysdir, "cdt", "", 0, 1, scdtp, code);
	     if scdtp = null then
		call sys_log$error_log (SL_LOG_BEEP, code, ME, "^a>cdt",
		     sysdir);
	end;
	call cu_$arg_count_rel (arg_count, arg_list_ptr, (0));
						/* AF invocation not an issue */
	return;					/* end of setup */
     end validate;

/* ****************************************************************************************************************** */

abs_maxu:
     proc (l_arg);

dcl  l_arg char (*);

	i = cv_dec_check_ (l_arg, code);
	if code = 0 then				/* check legality */
	     if i >= 0 then
		if i <= divide (anstbl.max_units, 10, 17, 0) then
		     do;
		     autbl.abs_maxu_auto = ""b;
		     autbl.max_abs_users = i;
		     whotab.max_abs_users = i;
		     return;
		end;
	if code ^= 0 then
	     answer = "abs maxusers must be numeric or ""auto"": " || l_arg;
	else if i < 0 then
	     answer = "abs maxusers may not be negative: " || l_arg;
	else
	     answer =
		"abs maxusers may not be greater than system maxusers: " || l_arg;
	go to admin_answers;
     end abs_maxu;

/* ****************************************************************************************************************** */

abs_maxq:
     proc (l_arg);

dcl  l_arg char (*);

	i = cv_dec_check_ (l_arg, code);
	if code = 0 then				/* check legality */
	     if i >= 0 then
		if i <= absolute_max_queue then
		     do;
		     autbl.abs_maxq_auto = ""b;
		     autbl.last_queue_searched = i;
		     return;
		end;
	answer = "abs maxqueue has invalid value: " || l_arg;
	go to admin_answers;
     end abs_maxq;

/* ****************************************************************************************************************** */

build_string:
     proc (arg_list_ptr, an);

dcl  arg_list_ptr pointer;

dcl  an fixed bin;					/* arg no to start from */

dcl  i fixed bin;

	i = an;
	call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr);
	if code ^= 0 then
	     go to admin_err;
	string = arg;
	strl = lng;
bld:
	i = i + 1;
	call cu_$arg_ptr_rel (i, p, lng, code, arg_list_ptr);
	if code ^= 0 then
	     return;
	substr (string, strl + 2) = arg;
	strl = strl + 1 + lng;
	if strl > length (string) then
	     return;
	go to bld;

     end build_string;
%page;
/* Internal procedure to do the work of the STOP command.
   Called by the STOP command and the timer for the DOWN command. */

stop_command:
     procedure ();

	if stopflag then
	     return;				/* ignore subsequent stop commands */
	stopflag = "1"b;				/* prevent resignal */

	whotab.nextsd = 0;				/* a shutdown will prevent restoring */
	call SET_LOGIN_WORD ("shutdown");		/* ok, no more logins. Set dialup message */

	if anstbl.n_users = 0 then			/* ready to shut down already? */
	     call sys_log (SL_LOG, "^a: stop: All users are out. You may shut down.", ME);
	else
	     do;					/* Bump everyone still on */
	     call convert_status_code_ (as_error_table_$sys_down_msg, shortinfo,
		longinfo);
	     if whotab.until = 0 then
		string = "";
	     else
		do;
		msg = date_time_$format ("date_time", whotab.until, "", "");
		call convert_status_code_ (as_error_table_$try_again_at_msg,
		     shortinfo, longinfo1);
		call ioa_$rsnnl (longinfo1, string, i, msg);
	     end;
	     call ioa_$rs (longinfo, prefix, i, string);

	     continue = "1"b;
	     string = substr (prefix, 1, i - 1);

	     do i = 1 to anstbl.current_size while (continue); /* everybody out of the pool */
		utep = addr (anstbl.entry (i));
		if ute.active >= NOW_LOGGED_IN
		then call PROCESS_UTE (action_flag);
	     end;

	     if ^action_flag
	     then call sys_log (SL_LOG,
		     "^a: stop: There were no active users to be bumped.", ME);
	     else call sys_log (SL_LOG,
		     "^a: stop: all users have been given ^d minutes to logout",
		     ME, divide (installation_parms.warning_time, SECS_IN_MIN, 17, 0));
	end;

	return;


PROCESS_UTE:
	procedure (P_action_flag);

/* *** This procedure is used to perform the desired action on the
   specified ute.  The action is specified via the variable "action". */

dcl  P_action_flag bit (1) aligned parameter;

	     if ute.at.nobump
	     then do;
		call sys_log (SL_LOG, "^a: ^a: ^a.^a has ""nobump""", ME, comname,
		     ute.person, ute.project);
		if ^ute.uflags.disconnected
		then call asu_$blast_user (utep, "Bump attempted.  " ||
			string, (""), (0));
		return;
	     end;

	     call asu_$bump_user (utep, string, code,
		installation_parms.warning_time);

/* *** This tells the operator what we did and sets the flag saying that
   we did something. */

	     call sys_log (SL_LOG, "^a: bump: ^a.^a bumped.", ME, ute.person, ute.project);
	     P_action_flag = "1"b;			/* remember we did one */
	     return;

	end PROCESS_UTE;

     end stop_command;

%page;

parse_abs_args:
     proc (arg_list_ptr);				/* fills in abs_args structure from job selection args */

dcl  arg_list_ptr pointer;

dcl  an fixed bin;					/* arg number */
dcl  expecting fixed bin init (0);			/* if nonzero, which arg value are we expecting */
dcl  prev_arg char (20);				/* previous argument, for use in error messages */
dcl  ctl_arg_given bit (1) aligned init (""b);
						/* 1 if any control args have been processed */
dcl  USER fixed bin int static
	options (constant) init (1);
						/* values for expecting */
dcl  ID fixed bin int static
	options (constant) init (2);
dcl  ENTRY fixed bin int static
	options (constant) init (3);
dcl  SENDER fixed bin int static
	options (constant) init (4);
dcl  QUEUE fixed bin int static
	options (constant) init (5);

	unspec (abs_args) = ""b;			/* clear out argument structure */
	do an = 2 to nargs;				/* skip first arg, which is command keyword */
	     call cu_$arg_ptr_rel (an, p, lng, code, arg_list_ptr);
	     if code ^= 0 then
		goto admin_err;

	     if substr (arg, 1, 1) = "-" then
		do;				/* a control argument */
		if expecting > 0 then
		     do;				/* but if we were expecting a value, complain */
		     call sys_log$error_log (SL_LOG, error_table_$noarg, comname,
			"After ^a.", prev_arg);
		     return;
		end;

		if arg = "-user" then
		     expecting = USER;
		else if arg = "-id" then
		     expecting = ID;
		else if arg = "-et" | arg = "-entry" then
		     expecting = ENTRY;
		else if arg = "-sender" then
		     expecting = SENDER;
		else if arg = "-q" | arg = "-queue" then
		     expecting = QUEUE;
		else if arg = "-fg" | arg = "-foreground" then
		     do;				/* equivalent to -q foreground */
		     if abs_args.queue_sw then
			do;
multiple_abs_qualifiers:
			answer =
			     "More than one specification of an attribute is present: "
			     || arg;
			go to admin_answers;
		     end;
		     abs_args.queue_sw = "1"b;
		     abs_args.queue = -1;
		end;
		else
		     do;
		     answer = "Invalid abs job selection argument: " || arg;
		     goto admin_answers;
		end;
		prev_arg = arg;			/* save this arg in case of error with next one */
		ctl_arg_given = "1"b;		/* remember not to allow any more positional args */
	     end;					/* end control arg */

	     else if expecting > 0 then
		do;				/* expecting something; pick up value in appropriate way */
		if expecting = USER then
		     call get_user (arg_list_ptr);
		else if expecting = ID then
		     call get_id;
		else if expecting = ENTRY then
		     do;
		     if abs_args.entry_sw then
			go to multiple_abs_qualifiers;
		     abs_args.entry_sw = "1"b;
		     abs_args.ename = arg;
		end;
		else if expecting = SENDER then
		     do;
		     if abs_args.sender_sw then
			go to multiple_abs_qualifiers;
		     abs_args.sender_sw = "1"b;
		     abs_args.sender = arg;
		end;
		else if expecting = QUEUE then
		     do;
		     if abs_args.queue_sw then
			go to multiple_abs_qualifiers;
		     abs_args.queue_sw = "1"b;
		     if arg = "fg" | arg = "foreground" then
			abs_args.queue = -1;
		     else
			do;
			temp = arg;		/* align arg */
			abs_args.queue = cv_dec_check_ (temp, code);
			if code ^= 0 then
			     do;
			     answer = "Invalid queue number " || arg;
			     goto admin_answers;
			end;
		     end;
		end;
		expecting = 0;
	     end;

	     else if substr (arg, 1, 3) = "abs" then
		do;
		if abs_args.absn_sw | abs_args.abs_star_sw then
		     go to multiple_abs_qualifiers;
		if verify (substr (arg, min (4, length (arg))), DIGITS) = 0 then
		     do;				/* absN */
		     abs_args.absn_sw = "1"b;
		     temp = substr (arg, 4);		/* align N */
		     abs_args.aut_index = cv_dec_check_ (temp, (0));
		end;

		else if arg = "abs*" then		/* abs* means all running jobs */
		     abs_args.abs_star_sw = "1"b;
	     end;

	     else if substr (arg, 1, 1) = ">" then
		do;				/* pathname */
		if abs_args.path_sw then
		     go to multiple_abs_qualifiers;
		abs_args.path_sw = "1"b;
		call expand_pathname_ (arg, abs_args.dirname, abs_args.ename,
		     code);
		if code ^= 0 then
		     do;
		     answer = arg;
		     goto admin_err;
		end;
	     end;

	     else if an > 3 | ctl_arg_given then
		do;				/* if n.o.t.a., and positional args no longer allowed, complain */
full_path_required:					/* come here from below if positional arg has wrong format */
		answer = "Relative pathnames not allowed: " || arg;
		goto admin_answers;
	     end;
	     else if verify (arg, "0123456789.") = 0 then /* just digits and dot must be request ID */
		call get_id;
	     else if index (CAPITALS, substr (arg, 1, 1)) ^= 0
						/* if it begins with capital, could be user name */
		| substr (arg, 1, 1) = "*" then	/* and * is also legal as user name */
		call get_user (arg_list_ptr);
	     else
		goto full_path_required;		/* else assume it's a pathname and reject it */
	end;

	if abs_args.entry_sw | abs_args.path_sw then
	     do;					/* check on absin suffix */
	     i = length (rtrim (abs_args.ename));
	     if substr (abs_args.ename, max (1, i - 5), 6) ^= ".absin" then
						/* if suffix missing */
		if substr (abs_args.ename, i, 1) ^= "*" then
						/* avoid screwing up starnames */
		     if i < 27 then			/* or running off the end of the string */
			substr (abs_args.ename, i + 1, 6) = ".absin";
						/* add the suffix */
	end;

	return;

/* ---------- */

get_id:
	proc;
	     if abs_args.id_sw then
		go to multiple_abs_qualifiers;
	     abs_args.id_sw = "1"b;
	     abs_args.request_id_string = arg;
	     return;

	end get_id;

/* ---------- */

get_user:
	proc (arg_list_ptr);
dcl  arg_list_ptr pointer;

	     if abs_args.user_sw then
		go to multiple_abs_qualifiers;
	     abs_args.user_sw = "1"b;
	     abs_args.person = before (arg, ".");
	     abs_args.project = before (after (arg, "."), ".");
	     if abs_args.person = "" then
		abs_args.person = "*";
	     if abs_args.project = "" then
		do;				/* allow operator to forget dot between person and project */
		call cu_$arg_ptr_rel (an + 1, p, lng, code, arg_list_ptr);
						/* look for project in next arg */
		if code = 0 then
		     do;				/* if there is a next arg */
		     if lng <= 9
			& (index (CAPITALS, substr (arg, 1, 1)) ^= 0 | arg = "*")
		     then
			do;			/* if it could be proj name */
			abs_args.project = arg;	/* assume it is */
			an = an + 1;		/* and move past this arg */
		     end;
		end;
	     end;
	     if abs_args.project = " " then
		abs_args.project = "*";		/* if no project name anywhere, assume * */
	     return;

	end get_user;

     end parse_abs_args;
%page;
validate_abs_args:
     proc (absn_ok, user_rqd);			/* see if abs args are ok for this abs command */

dcl  absn_ok bit (1) aligned;				/* 1 of absN arg accepted by this command */
dcl  user_rqd bit (1) aligned;			/* 1 if user name required by this command */

	if unspec (abs_args.arg_switches) = ""b then
	     do;					/* if no args were given, complain */
	     answer = "No job selection arguments given.";
	     goto admin_answers;
	end;

	if user_rqd then
	     do;					/* if command requires user name */
	     if ^abs_args.user_sw then
		do;
		answer = "User name must be given.";
		goto admin_answers;
	     end;
	     else if abs_args.person = "*" then
		do;
		answer = "User name (not ""*"") must be given.";
		goto admin_answers;
	     end;
	end;

	if ^absn_ok then
	     if abs_args.absn_sw then
		do;
		answer = "The absN argument is not valid.";
		goto admin_answers;
	     end;

	return;

     end validate_abs_args;
%page;
get_pers_proj:
     proc (arg_list_ptr, a_ix, P_new_arg_index, code);

/* *** Accept command arguments "Person.Project" or "Person Project"
   from the argument list begining at argument a_ix and update
   set P_new_arg_index to the index the next argument.  A number of
   checks are made unless the brief entry is called. */

dcl  P_new_arg_index fixed bin (17) parameter;
dcl  a_ix fixed bin parameter;
dcl  arg_list_ptr pointer;
dcl  code fixed bin (35);				/* ^= 0 --> print a usage message */

dcl  flag bit (1) aligned;

	flag = "1"b;
	go to get_pp_common;

get_pers_proj$$brief:
     entry (arg_list_ptr, a_ix, P_new_arg_index, code);

	flag = "0"b;

get_pp_common:
	P_new_arg_index = a_ix;			/* initialize argument index */
	wpers, wproj = "";
	call cu_$arg_ptr_rel (P_new_arg_index, p, lng, code, arg_list_ptr);
	if code ^= 0 then
	     return;
	if index (arg, ".") ^= 0 then
	     do;
	     wpers = before (arg, ".");
	     wproj = after (arg, ".");
	     if flag then
		if length (rtrim (wpers)) > 22 then
LONG_PERSON:
		     do;
		     call ioa_$rsnnl ("Personid ^a > 22 characters.", answer,
			(0), wpers);
		     go to admin_answers;
		end;
	     if wproj = "" then
BAD_PP:
		do;
		call ioa_$rsnnl ("^a is not a valid Person.Project.", answer,
		     (0), arg);
		go to admin_answers;
	     end;
	end;
	else
	     do;
	     wpers = arg;
	     if flag then
		if length (rtrim (wpers)) > 22 then
		     go to LONG_PERSON;
	     P_new_arg_index = P_new_arg_index + 1;
	     call cu_$arg_ptr_rel (P_new_arg_index, p, lng, code, arg_list_ptr);
	     if code ^= 0 then
		go to BAD_PP;			/* Read this as bad per.proj rather than missing proj in per proj. */
	     wproj = arg;
	end;
	if length (rtrim (wproj)) > 9 then
	     if flag then
		do;
		call ioa_$rsnnl ("Projectid ^a is longer than 9 characters.",
		     answer, (0), wproj);
		go to admin_answers;
	     end;
	P_new_arg_index = P_new_arg_index + 1;
	return;

     end get_pers_proj;
%page;
set_non_command_sys_loggers:
     procedure;

	sys_log = sys_log_;
	sys_log$error_log = sys_log_$error_log;
	return;
     end set_non_command_sys_loggers;
%page;
SCHEDULE_ABSENTEE_SHUTDOWN:
     procedure ();

/* *** This procedure schedules an absentee shutdown. */

dcl  time fixed bin (71) automatic;
						/* temporary */
dcl  time_str char (48) automatic;
						/* temporary */

	call ipc_$create_ev_chn (abs_stop_chn, (0));
	call ipc_$decl_ev_call_chn (abs_stop_chn, admin_$absentee_down, null,
	     SHUTDOWN_PRIO, (0));
	time = whotab.nextsd - (abs_shut_interval - abs_shut_offset) * MILLION;
	call timer_manager_$alarm_wakeup (time, "00"b, abs_stop_chn);
	time_str = date_time_$format ("date_time", time, "", "");
	call sys_log (SL_LOG, "^a: abs: auto abs stop will be at ^a", ME, time_str);
	return;

     end SCHEDULE_ABSENTEE_SHUTDOWN;
%page;
CHECK_FOR_ABSENTEE_SHUTDOWN:
     procedure ();

/* *** This procedure is called to check to see if all absentee processes
   have logged out in preparation for an absentee shutdown.  If they
   have, we shut down the absentee facility and perform a non-local
   goto to admin_abs_returns (ugh). */

	if ^autbl.abs_stopped then			/* we have cancelled the shutdown */
	     return;

	if autbl.n_abs_run = 0 then			/* check that all absentee processes have logged out */
	     do;
	     call sys_log (SL_LOG,
		"^a: abs: All absentee processes have run to completion.", ME);
	     call ipc_$delete_ev_chn (abs_stop_chn, code);/* delete event channel created */
	     call absentee_user_manager_$term_aum;	/* close out absentee facility */
	     autbl.abs_up = ""b;			/* indicate that absentee is down */
	     call absentee_user_manager_$update_whotab_abs_control ();
	end;

/* if an extra-ordinary amount of time has elapsed since abs stop */
/* and there are still absentee processes, bump them */

	else if n_called > abs_shut_interval then
	     do;
	     call sys_log (SL_LOG,
		"^a: abs: Bumping all remaining absentee processes.", ME);
	     if sys_log = sys_log_ then		/* we are NOT a command */
		call admin_$abs_not_a_command_ ("bump", "*", "*");
	     else
		call admin_$abs ("bump", "*", "*");
	     call absentee_user_manager_$update_whotab_abs_control ();
	end;

	else					/* otherwise, check again in 30 seconds */
	     call timer_manager_$alarm_wakeup (30, "11"b, abs_stop_chn);
	return;

     end CHECK_FOR_ABSENTEE_SHUTDOWN;
%page;
START_ABSENTEE_SHUTDOWN:
     procedure ();

/* *** This procedure is called to start shutting down the absentee
   facility. */

	saved_max_abs_users = autbl.max_abs_users;	/* remember in case we must
						   reset */
	whotab.max_abs_users,			/* set max abs users to -1 in whotab */
	     autbl.max_abs_users = -1;		/* and in absentee user table */
	autbl.abs_stopped = "1"b;			/* record fact that absentee is being shutdown */
	saved_abs_maxu_auto = autbl.abs_maxu_auto;	/* remember in case we must reset */
	autbl.abs_maxu_auto = ""b;			/* tell load_ctl_ not to change abs maxu */

/* *** reuse the event channel for our own internal timer.  It will
   allow us to check every 30 seconds to ensure all processes are
   logged out before we shut down. */

	call ipc_$decl_ev_call_chn (abs_stop_chn, admin_$absentee_off, null (),
	     SHUTDOWN_PRIO, code);

/* *** Check to see if all absentee processes are done yet.  If not, schedule
   a check every 30 seconds. */

	call CHECK_FOR_ABSENTEE_SHUTDOWN ();
	return;
     end START_ABSENTEE_SHUTDOWN;
%page;
NOTIFY_USERS_OF_SHUTDOWN_TIME_CHANGE:
     procedure ();

/* *** This procedure sends a system_shutdown_scheduled_ IPS signal to all
   interactive, absentee, and daemon users on the system. */

dcl  ute_index fixed bin;

	dutp = as_data_$dutp;
	do ute_index = 1 to dutbl.current_size;
	     utep = addr (dutbl.entry (ute_index));
	     if ute.active > NOW_LOGGED_IN then
		call hphcs_$ips_wakeup (ute.proc_id,
		     "system_shutdown_scheduled_");
	end;

	autp = as_data_$autp;
	do ute_index = 1 to autbl.current_size;
	     utep = addr (autbl.entry (ute_index));
	     if ute.active > NOW_LOGGED_IN then
		call hphcs_$ips_wakeup (ute.proc_id,
		     "system_shutdown_scheduled_");
	end;

	do ute_index = 1 to anstbl.current_size;
	     utep = addr (anstbl.entry (ute_index));
	     if ute.active > NOW_LOGGED_IN then
		call hphcs_$ips_wakeup (ute.proc_id,
		     "system_shutdown_scheduled_");
	end;
     end NOTIFY_USERS_OF_SHUTDOWN_TIME_CHANGE;
%page;
SCHEDULE_SYSTEM_SHUTDOWN:
     procedure (P_shutdown_time, P_shutdown_reason, P_down_until_time);

/* *** This procedure schedules a system shutdown.  */

dcl  P_shutdown_time fixed bin (71) parameter;
						/* when we're shutting down */
dcl  P_shutdown_reason char (*) parameter;		/* why */
dcl  P_down_until_time fixed bin (71) parameter;
						/* when we'll be back up */

	whotab.nextsd = P_shutdown_time;		/* publish the shutdown time */
	whotab.obsolete_why =
	     substr (P_shutdown_reason, 1, length (whotab.obsolete_why));
	whotab.why = P_shutdown_reason;
	whotab.until = P_down_until_time;

	call ipc_$create_ev_chn (auto_bump_chn, (0));
	call ipc_$decl_ev_call_chn (auto_bump_chn, admin_$timed_stop_command, null,
	     SHUTDOWN_PRIO, (0));
	call timer_manager_$alarm_wakeup (whotab.nextsd
	     - installation_parms.warning_time * MILLION, "00"b, auto_bump_chn);

	goingdown = "1"b;				/* indicate that a shutdown has been scheduled */

	msg = date_time_$format ("date_time", whotab.nextsd, "", "");
	call sys_log (SL_LOG, "^a: down: auto shutdown will be at ^a", ME, msg);

	if autp ^= null then
	     if autbl.abs_up then
		do;				/* if absentee running */
		call SCHEDULE_ABSENTEE_SHUTDOWN ();
		call absentee_user_manager_$update_whotab_abs_control ();
	     end;

/* *** And make sure we tell all the users of the new shutdown time */

	call NOTIFY_USERS_OF_SHUTDOWN_TIME_CHANGE ();
	return;
     end SCHEDULE_SYSTEM_SHUTDOWN;
%page;
CANCEL_SYSTEM_SHUTDOWN:
     procedure (P_message, P_code);

/* *** This procedure is called to cancel a system shutdown.  It also
   cancels the absentee shutdown if it has not already been performed. */

dcl  P_message char (*) parameter;			/* reason why we didn't. */
dcl  P_code fixed bin (35) parameter;
						/* status code */

	if whotab.nextsd = 0 then
	     do;					/* no shutdown scheduled */
	     P_message = "no system shutdown scheduled";
	     P_code = error_table_$action_not_performed;
	end;
	else
	     do;					/* there is a shutdown scheduled */
	     call timer_manager_$reset_alarm_wakeup (auto_bump_chn);
	     goingdown = "0"b;			/* static flag */
	     whotab.nextsd = 0;			/* change whotab to show no shutdown expected */
	     whotab.message = "";
	     whotab.obsolete_message = "";
	     whotab.until = 0;
	     if autp ^= null () then
		if autbl.abs_up then		/* if absentee running */
		     do;
		     call timer_manager_$reset_alarm_wakeup (abs_stop_chn);
						/* cancel automatic abs stop */
		     if autbl.abs_stopped then
			call ABORT_ABSENTEE_SHUTDOWN ();
		end;
	     call NOTIFY_USERS_OF_SHUTDOWN_TIME_CHANGE ();
	end;
	return;
     end CANCEL_SYSTEM_SHUTDOWN;
%page;
ABORT_ABSENTEE_SHUTDOWN:
     procedure ();

/* *** This procedure is called to cancel an absentee shutdown which has
   already started.  That is, when we have already started waiting for
   absentees to complete before really shutting the absentee facility
   down. */

	autbl.abs_stopped = "0"b;			/* turn off this flag */
	autbl.abs_maxu_auto = saved_abs_maxu_auto;	/* restore saved values */
	autbl.max_abs_users,			/* restore saved values */
	     whotab.max_abs_users = saved_max_abs_users;
	return;
     end ABORT_ABSENTEE_SHUTDOWN;
%page;
SET_LOGIN_WORD:
     procedure options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();

	call validate;				/* locate answer table */
	call cu_$arg_ptr_rel (1, p, lng, code, arg_list_ptr);
						/* get the new login word */
	if code ^= 0 then
	     do;
	     lng = max (0, anstbl.message_lng - 1);	/* set length of message to omit trailing newline */
	     call sys_log (SL_LOG,
		"^a: word: ^a; ^a message: ^[^a^;"""" (NO MESSAGE)^]",
		ME, anstbl.login_word, anstbl.session, (anstbl.message_lng > 1),
		based_anstbl_message);
	     return;
	end;
	if lng > 8 then
	     do;					/* check length */
	     call sys_log (SL_LOG,
		"^a: word: length of login-word must not exceed 8 characters", ME);
	     return;
	end;
	do i = 3 to hbound (as_data_login_words.words, 1)
	     while (arg ^= as_data_login_words.words (i));
	end;
	if i <= hbound (as_data_login_words.words, 1) then
	     do;					/* Cannot use special word as login word */
	     call sys_log (SL_LOG, "^a: word: ^a is a reserved word.", ME, arg);
	     return;
	end;
	anstbl.login_word = arg;			/* change the login word */
	call cu_$arg_ptr_rel (2, p, lng, code, arg_list_ptr);
						/* ??? */
	if code = 0 then
	     do;					/* if message given on command line */
	     call build_string (arg_list_ptr, 2);	/* build up message */
	     if strl > length (anstbl.special_message) then
		do;
		strl = length (anstbl.special_message);
		call sys_log (SL_LOG,
		     "^a: word: message truncated; maximum length is ^d characters",
		     ME, strl);
	     end;
	     anstbl.special_message = substr (string, 1, strl);
						/* set dialup buffer */
	     anstbl.message_lng, lng = strl;		/* and length */
	end;
	else
	     lng = 0;				/* no buffer set */
	if anstbl.login_word = as_data_login_words.words (1) then
						/* "l" */
	     go to wordl;				/* Normal session? */
	if anstbl.login_word = as_data_login_words.words (2) then
						/* "login" */
	     do;
wordl:
	     stopflag = "0"b;			/* yes. cancel stop */
	     anstbl.session, whotab.session = "normal";	/* allow logins to proceed */
	     if lng = 0 then
		do;
		anstbl.message_lng = 0;		/* if changed word, reset buffer */
		anstbl.special_message = "";
	     end;
	end;
	else
	     do;					/* not normal session */
	     anstbl.session, whotab.session = "special";	/* assume special */
	     if lng = 0 then
		do;				/* if no message specified */
		if anstbl.login_word = "shutdown" then
		     do;				/* if shutting down */
		     call convert_status_code_ (as_error_table_$sys_down_msg,
			shortinfo, longinfo);
		     if whotab.until = 0 then
			string = "";		/* if not specified when come up */
		     else
			do;			/* can say when to try again */
			day_back =
			     date_time_$format ("^yc^my^dm", whotab.until, "", "");
			day_now =
			     date_time_$format ("^yc^my^dm", clock (), "", "");

			if day_back = day_now	/* days different? */
			then msg = date_time_$format ("time", whotab.until, "", "");
			else msg = date_time_$format ("date_time", whotab.until, "", "");

			call convert_status_code_ (
			     as_error_table_$try_again_at_msg, shortinfo,
			     longinfo1);
			call ioa_$rsnnl (longinfo1, string, i, msg);
		     end;
		     call ioa_$rsnnl (longinfo, anstbl.special_message, i,
			string);
		end;
		else
		     do;				/* special session not shutdown */
		     call convert_status_code_ (as_error_table_$special_sess_msg,
			shortinfo, longinfo);
		     anstbl.special_message = longinfo;
		end;				/* end special session */
		anstbl.message_lng = length (rtrim (anstbl.special_message));
	     end;
	end;					/* end not normal session */
	if anstbl.login_word = "shutdown" then
	     do;
	     anstbl.session, whotab.session = "shutdown";
	     fb71 = clock ();
	     b12 = substr (unspec (fb71), 34, 12);
	     call ioa_$rsnnl ("^4.3b", c4, (0), b12);
	     anstbl.login_word = c4;
	end;
	if anstbl.message_lng > 0 then
	     do;					/* if there is a message, print it for operator */
	     call sys_log (SL_LOG, "^a: word: ^a message: ^a", ME, anstbl.session,
		substr (anstbl.special_message, 1, anstbl.message_lng));
	     anstbl.message_lng =
		min (anstbl.message_lng + 1, length (anstbl.special_message));
	     substr (anstbl.special_message, anstbl.message_lng, 1) = NL;
	end;

	call dialup_$re_introduce;			/* say hello again */

/* *** Update the "time of last message update" so that the login servers
   will notice the change and redisplay the login banner */

	anstbl.message_update_time = clock ();
	return;
     end SET_LOGIN_WORD;
%page;

/* format: off */
%page; %include abs_args;
%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_wakeup_priorities;
%page; %include author_dcl;
%page; %include cdt;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include installation_parms;
%page; %include sc_stat_;
%page; %include sc_subsystem_info_;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   admin_: down: No shutdown is scheduled.

   S:	$as1

   T:	In response to an operator down command.

   M:	The operator issued a down 0 command to reset a scheduled
   automatic shutdown when none was in effect.  No action was taken
   on the command.

   A:	$ignore

   Message:
   admin_: down: Next shutdown from DATE_TIME to DATE_TIME1 REASON

   S:	$as1

   T:	Response to an operator "down" command.

   M:	This message tells when the next scheduled shutdown is.

   A:	$ignore

   Message:
   admin_: down: resetting previous shutdown at MM/DD/YY HHMM.T

   S:	$as1

   T:	In response to an operator down command.

   M:	A second down command has been issued before a previously
   issued down command has been executed.  The new shutdown time is
   honored instead of the previous one.

   A:	$ignore

   Message:
   admin_: stop: Automatic shutdown

   S:	$as1

   T:	$shut

   M:	A down command issued earlier has taken effect.  An
   automatic stop command is executed.  All users are
   bumped in three minutes.

   A:	Prepare to shut down the system.

   Message:
   admin_: warn: NAME.PROJ has "no_warning"

   S:	$as1

   T:	Response to operator warn command.

   M:	This is the response to the command "warn NAME PROJ
   Message..." if the user has specified the -no_warning argument
   at login.  The message is not sent to the user.

   A:	Attempt to contact the user by other means.

   Message:
   admin_: warn: USER.PROJ not connected to a channel

   S:     as (sevreity1)

   T:     Response to operator warn command.

   M:     This is the response to the command "warn NAME PROJ Message"
   if the pointer to the channel table entry in the user table entry
   for the named user (ute.cdtep) is not set (null).  The message cannot be
   sent to the user.

   A:	Attempt to contact the user by other means.

   Message:
   admin_: warn: NAME.PROJ not found.

   S:	$as1

   T:	In response to an operator warn command.

   M:	The warn command was issued for a nonexistent user.  No
   action was taken.

   A:	The user is probably not logged in.  Check the spelling of
   the name.  $tryagain

   Message:
   admin_: log: MESSAGE

   S:	$as0

   T:	$run

   M:	The log command simply enters its arguments in the system log.
   It is occasionally used by
   operators and system programmers to record events.

   A:	$ignore

   Message:
   admin_: maxu: (MMMM): UUUU (DDDD normal users)
   
   S:	$as1

   T:     When operator entered "maxu" command.

   M:     This is an informative message indicating the current values
   manipulated by the maxu command.  MMMM is the mode, "auto" or "level".
   UUUU is the load units in tenths.  DDDD is the load units in whole numbers.

   A:     $ignore

   Message:
   admin_: maxu: Warning: maxunits are in tenths of load units.
   .brf
             You just set maxu to UUUU, or DDDD normal users.

   S:	$as1

   T:     When operator entered a maxu command line that specified < 200 load
   units or 20 normal users.

   M:     This message is a warning to the operator that he may have made a
   mistake in setting the load units of the system.  A normal system is not
   likely to set its maximum load units to less than 200.

   A:     Take corrective action (reenter the command with corrected
   arguments).

   Message:
   admin_: shift: N until DATE_TIME

   S:	$as1

   T:	response to an operator "shift" command.

   M:	The operator has issued the shift command.
   If issued with no arguments this command types the current setting.
   If issued with arguments,
   the command changes the shift and types the new value.

   A:	$ignore

   Message:
   admin_: ERROR_MESSAGE SYSDIR>absentee_user_table

   S:	$as1

   T:     When operator entered abs command.

   M:     The ERROR_MESSAGE gives reason why system was not able to find or
   access the absentee_user_table in the SYSDIR directory.  Execution of the
   command was not completed.

   A:     %inform

   Message:
   admin_: abs: absentee not up, and will not be started automatically

   S:	$as1

   T:     When operator entered "abs stop" before absentee facility was
   started.

   M:     The command can be entered at standard to prevent the absentee
   facility from starting up automatically after a "startup" command is used.

   A:     $ignore

   Message:
   admin_: abs: resetting auto abs stop

   S:	$as1

   T:	In response to an operator abs stop command.

   M:	An abs stop command overrides an automatic abs stop
   that was set up by a down command.

   A:	$ignore

   Message:
   admin_: stop: auto abs stop

   S:	$as1

   T:	$run

   M:	It is 30 minutes before an automatic stop, so an automatic
   abs stop command is being issued.  This is the result of a previous
   down command.  Refer also to the stop command description.

   A:	$ignore

   Message:
   admin_: abs: Zero errors on all absentee queues.

   S:	$as1

   T:     In response to "abs queue" operator command.

   M:     Informative message which indicates that no queue has been dropped
   and no errors recorded for any queue.

   A:     $ignore

   Message:
   admin_: abs: Queue errors (*=dropped):
   .brf
   admin_: abs: FG  0  1  2  3  4
   .brf
   admin_: abs: TT VV WW XX YY ZZ
   .brf
   admin_: abs:  *  *  *  *  *  *

   S:	$as1

   T:     In response to "abs queue" operator command.

   M:     Displays the errors for each queue and indicates which one has been
   dropped.  If none have been dropped, the last line will not be displayed nor
   will the string "(*=dropped)" appear in the first line.

   A:     $inform

   Message:
   admin_: abs: maxu (MMMM): UUUU

   S:	$as1

   T:     In response to "abs maxu" operator command without arguments.

   M:     Informative message indicating current status of maxu and maximum
   absentee users allowed.  MMMM is the mode, "auto" or "manual".  UUUU is the
   load_units.

   A:     $ignore

   Message:
   admin_: abs: maxq (MMMM): Q

   S:	$as1

   T:     In response to "abs maxq" without arguments.

   M:     Informative message indicating current status of maxq and queue last
   searched (Q).  MMMM is the mode, "auto" or "manual".

   A:     $ignore

   Message:
   admin_: abs: qres (MMMM): WW XX YY ZZ

   S:	$as1

   T:     In response to "abs maxq" without arguments.

   M:     Informative message indicating current status of absentee queue
   reservation for each queue.  MMMM is the mode, "auto" or "manual".

   A:     $ignore

   Message:
   admin_: abs: queue  limits: WW XX YY ZZ

   S:	$as1

   T:     In response to "abs qres" operator command.

   M:     Informative message indicating the current queue reservation limits.

   A:     $ignore

   Message:
   admin_: abs: cpu_limit (MMMM), queues 1-4: WW XX YY ZZ (seconds)

   S:     $as1

   T:     In response to "abs cpu_limit" command without arguments.

   M:     Informative message indicating current values of cpu_limit for each
   absentee queue.  MMM is the mode, "auto" or "manual".

   A:     $ignore

   Message:
   admin_: abs: Warning: cpu limits are in seconds. You just set queue QQ limit to LLLL seconds.

   S:     $as1

   T:     In response to "abs cpu_limit" command with arguments.

   M:     The cpu_limit (LLLL) for queue QQ is below 60 seconds which is likely
   to be a mistake.  The value already given will be still be accepted.

   A:     Reenter the command with corrected values if originally incorrect.

   Message:
   admin_: ERROR_MESSAGE SYSDIR>answer_table

   S:     $as2

   T:     In response to operator commands that require access to the system
   answer_table.

   M:     The ERROR_MESSAGE gives reason why system was not able to find or
   access the answer_table in the SYSDIR directory.  Execution of the
   command was not completed.

   A:     $inform

   Message:
   admin_: ERROR_MESSAGE SYSDIR>whotab

   S:     $as2

   T:     In response to operator commands that require access to the system
   whotab.

   M:     The ERROR_MESSAGE gives reason why system was not able to find or
   access the whotab in the SYSDIR directory.  Execution of the
   command was not completed.

   A:     $inform

   Message:
   admin_: ERROR_MESSAGE SYSDIR>installation_parms

   S:     $as2

   T:     In response to operator commands that require access to the system
   installation_parms.

   M:     The ERROR_MESSAGE gives reason why system was not able to find or
   access the installation_parms in the SYSDIR directory.  Execution of the
   command was not completed.

   A:     $inform

   Message:
   admin_: ERROR_MESSAGE SYSDIR>cdt

   S:     $as2

   T:     In response to operator commands that require access to the system
   cdt.

   M:     The ERROR_MESSAGE gives reason why system was not able to find or
   access the cdt in the SYSDIR directory.  Execution of the
   command was not completed.

   A:     $inform

   Message:
   admin_: stop: All users are out. You may shut down.

   S:	$as1

   T:	$shut

   M:	This is the response to the stop command if all users
   have been logged out.  This message provides a quick check of whether
   all users have been bumped since it does not adversely affect system
   operation to issue the stop command repeatedly.

   A:	Proceed with the shutdown.

   Message:
   admin_: stop: There were no active users to be bumped.

   S:     $as1

   T:     $shut

   M:     The system did not find any active users to be bumped.

   A:     $ignore

   Message:
   admin_: stop: all users have been given XXXX minutes to logout

   S:     $as1

   T:     $shut

   M:	A stop command, either manual or automatic, has been
   initiated.  All users have been warned that they have XXXX minutes
   to finish up and logout.  After XXXX minutes, all users will be
   bumped except those with the nobump attribute.  The login word
   has been set so that no more users may log in.  To cancel this shutdown,
   issue a word login command and an unbump * * command.

   A:     $ignore

   Message:
   admin_: COMMAND: PERSON.PROJECT has "nobump"

   S:     $as1

   T:     $shut

   M:     The PERSON.PROJECT user cannot be bumped by the automatic shutdown or
   in response to the stop command.  The nobump attribute is normally only used
   by system administrator users.

   A:     Try to contact the user to arrange a time to actually
   shutdown.  If necessary, the user can be bumped by specifying the channel
   name in the bump command.  This will only work if the process has not been
   disconnected.  Otherwise, you will have to answer "yes" to the shutdown
   command.

   Message:
   admin_: bump: USER.PROJECT bumped.

   S:     $as1

   T:     In response to the bump command or a system shutdown.

   M:     The specified user has been notified that he or she must get off the
   system.  If a grace time was specified, the user is allowed that amount of
   time to logout.  Otherwise, the user is removed from the system immediately.

   A:     $ignore

   Message:
   admin_: abs ABS_FUNCTION: Expected argument missing. After PREV_ARG.

   S:     $as1

   T:	In response to an operator abs command.

   M:     A required value to a control argument supplied in the "abs"
   command line is missing.

   A:     Reenter corrected command line.

   Message:
   admin_: abs: auto abs stop will be at MM/DD/YY HHMM.T

   S:	$as1

   T:	In response to an operator down command or at startup.

   M:	This is the response to a down command if the absentee
   facility is running, or to an abs start command if the absentee is
   brought up after a down time has been set.  The time for an automatic
   abs stop is 20 minutes before the system is to shut down.  An "abs stop now"
   is done 10 minutes after the scheduled shutdown.
   Refer also to the stop command description.

   A:	$ignore

   Message:
   admin_: abs: All absentee processes have run to completion.

   S:	$as1

   T:	When shutting down the absentee facility.

   M:	This message is printed after the operator has issued an
   abs stop command or the system has issued an automatic
   abs stop prior to shutdown.  The system allows 30 minutes for all absentee
   jobs to finish before logging them out, then prints the message.

   A:	It is now safe to proceed with the shutdown.

   Message:
   admin_: abs: Bumping all remaining absentee processes.

   S:	$as1

   T:	$shut

   M:	The absentee facility waits 30 minutes for all absentee jobs
   to run to completion after the abs stop command has been
   issued.  Then it types this message and bumps them all.
   Refer also to the stop command description.

   A:	$ignore

   Message:
   admin_: down: auto shutdown will be at MM/DD/YY HHMM.T

   S:	$as1

   T:	In response to an operator down command or at startup.

   M:	This is the response to the down command.  It indicates
   the scheduled shutdown time.  A down command is issued automatically
   at system startup time after a crash; if a down command was given before
   the crash occurred, and the time of the scheduled shutdown is more than
   30 minutes in the future.

   A:	If the value shown in the message is correct, proceed.
   If not correct, reset the shutdown by typing down 0 and
   then try again.

   Message:
   admin_: word: XXXX; TYPE message: TEXT

   S:	$as1

   T:	In response to an operator word command.

   M:	The operator issued the word command with no arguments, and
   the current values were typed. The login word is XXXX, the message
   is TEXT, and the type of session is TYPE.  The TEXT is displayed as the
   first line of the greeting banner to interactive users making the banner 3
   lines long.  If TEXT is "" (NO MESSAGE), then nothing is added to the normal
   2 line greeting banner.

   A:	Check the word, type, and message for accuracy.

   Message:
   admin_: word: length of login-word must not exceed 8 characters

   S:	$as1

   T:	In response to an operator word command.

   M:	The operator tried to set the login word with the word
   command but the first argument was too long.  No action was taken
   on the command.

   A:	$tryagain

   Message:
   admin_: word: XXXX is a reserved word.

   S:	$as1

   T:	In response to an operator word command.

   M:	The operator attempted to set the system login word to
   enter, enterp, e, ep, dial, or d.
   No action was taken.

   A:	Pick another word and type it in.

   Message:
   admin_: word: message truncated; maximum length is CCCC characters

   S:	$as1

   T:	In response to an operator word command.

   M:	The operator issued the command "word XXXX TEXT". The message
   TEXT was too long to fit in the dialup message buffer.
   The login word has been changed, and the dialup message
   has been set to the first CCCC characters of the given message.

   A:	Reword the message to fit within the CCCC-character limit,
   and retype the command.

   Message:
   admin_: word: TYPE message: TEXT

   S:	$as1

   T:	In response to an operator word command.

   M:	The operator issued the command "word XXXX TEXT".  The login
   word was set to XXXX, and a special buffer was loaded with the
   message TEXT so that it is typed out whenever a user dials up.
   The type of system session is TYPE; this may be special, normal,
   or shutdown.

   A:	Check the message for accuracy.

   Message:
   admin_: login: Entry not found. No MC ACS segment for the source SSSS.

   S:     $as1

   T:     In response to operator login command.

   M:     An MC ACS was not found in >sc1>mc_acs directory for the source
   identifier, SSSS.

   A:     $inform

   Message:
   admin_: login: ERROR_TABLE_MESSAGE Login not permitted for message coordinator source SSSS.

   S:     $as1

   T:     In response to operator login command.

   M:     The error identified by ERROR_TABLE_MESSAGE was encountered
   attempting to check the access to login the daemon whose source identifier
   is SSSS.

   Message:
   admin_: COMMAND: ERROR_TABLE_MESSAGE

   S:     $as1

   T:     In response to operator command, COMMAND.

   M:     The ERROR_TABLE_MESSAGE error was encounted when processing the
   operator command, COMMAND.

   A:     Type "help COMMAND" for details of the command's usage.

   Message:
   admin_: abs: ERROR_TABLE_MESSAGE PATHNAME

   S:     $as1

   T:     In response to the operator abs command.

   M:     The ERROR_TABLE_MESSAGE was encountered when trying to expand the
   PATHNAME supplied in the operator abs command line.

   A:     $tryagain

   Message:
   admin_: login: error: Usage: login Person.Project SOURCE {-control_args}

   S:     $as1

   T:     In response to operator login command with no arguments.

   M:     Informative message to operator when the login command was entered
   without arguments.

   A:     Also type "help login" for further details of command line syntax.

   Message:
   admin_: logout: error: Usage: logout Person.Project {SOURCE}

   S:     $as1

   T:     In response to operator logout command when entered without
   arguments.

   M:     Informative message indicating usage of the logout command.

   A:     Type "help logout" for further details of command usage.

   Message:
   admin_: down: error: no system shutdown scheduled

   S:     $as1

   T:     In response to operator entering, "down 0".

   M:     The "down 0" command line cancels a down but no system shutdown was
   scheduled.  No action was taken.

   A:     $ignore

   Message:
   admin_: down: error: XXX invalid clock time.

   S:	$as1

   T:	In response to an operator down command.

   M:	The time arguments of a down command must be specified in
   4-digit time or some form acceptable to convert_date_to_binary_.  No action
   was taken.  If the second time argument is an invalid time, it is considered
   part of the message.  This message is also displayed if the first time
   argument is not in the future.

   A:	$tryagain

   Message:
   admin_: down: error: uptime is earlier than downtime.

   S:     $as1

   T:     In response to an operator down command.

   M:     The operator down command specifies that the expected time that the
   system will be up is before the time that it is scheduled to be shutdown.
   No action was taken.

   A:     $tryagain

   Message:
   admin_: stop: error: no arguments are allowed for "stop"

   S:	$as1

   T:	In response to an operator stop command.

   M:	The operator has given an argument to the stop
   command.  No arguments are allowed.  No action was taken.

   A:	If abs stop was meant, type that command.  If stop
   was meant, type that command instead.  If "down ...." was meant,
   type in that command.

   Message:
   admin_: warn: error: Usage: warn Person.Project MESSAGE

   S:     $as1

   T:     In response to an operator warn command without any arguments.

   M:     Informative message indicating usage of the warn command.

   A:     Also, type "help warn" for more details on warn command usage.

   Message:
   admin_: rcp: error: unknown rcp command RRRR

   S:     $as1

   T:     In response to an operator rcp command.

   M:     The operator has entered an unknown rcp operator on the command line.

   A:     Type "help rcp" for further details on rcp command usage.

   Message:
   admin_: maxunits: error: XXX invalid value for maxunits

   S:	$as1

   T:	In response to an operator maxunits command.

   M:	The argument of the maxunits command was not a number, or
   was zero, or negative.  No action was taken.

   A:	$tryagain

   Message:
   admin_: shift: error: XXXX is not a legal shift number.

   S:     $as1

   T:     In response to an operator shift command.

   M:     A shift argument to the shift command was not a valid decimal number
   between 1 and 6 inclusive.

   A:     $tryagain

   Message:
   admin_: shift: error: CCCC invalid clock time.

   S:     $as1

   T:     In response to an operator shift command.

   M:     The time argument of the shift command is not a valid clock time
   acceptable to convert_date_to_binary_.

   A:     $tryagain

   Message:
   admin_: shift: error: CCCC is not within the next week.

   S:     $as1

   T:     In response to an operator shift command.

   M:     The time argument of the shift command cannot specify a time stamp
   that is over a week in the future.

   A:     $tryagain

   Message:
   admin_: fdump_fnp: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator fdump_fnp command.

   M:     An unknown argument, AAAA, was encountered in the fdump_fnp command.
   This is an obsolete command.  No action was taken.

   A:     Type "help dump_mpx" for details of the dump_mpx command and try
   again.

   Message:
   admin_: dump_fnp: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator dump_fnp command.

   M:     An unknown argument, AAAA, was encountered in the dump_fnp command
   line.  This is an obsolete command.  No action was taken.

   A:     Type "help dump_mpx" for details of the dump_mpx command and try
   again.

   Message:
   admin_: dump_mpx: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator dump_mpx command.

   M:     An unknown argument, AAAA, was encountered in the dump_mpx command
   line.  No action was taken.

   A:     Type "help dump_mpx" for details of the dump_mpx command and try
   again.

   Message:
   admin_: load_fnp: unknown argument AAAA

   S:     $as1

   T:     In response to an operator load_fnp command.

   M:     An unknown argument, AAAA, was encountered in the load_fnp command
   line.  This is an obsolete command.  No action was taken.

   A:     Type "help load_mpx" for details of the load_mpx command and try
   again.

   Message:
   admin_: load_mpx: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator load_mpx command.

   M:     An unknown argument, AAAA, was encountered in the load_mpx command
   line.  No action was taken.

   A:     Type "help load_mpx" for details of the load_mpx command and try
   again.

   Message:
   admin_: load_mpx: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator load_mpx command.

   M:     An unknown argument, AAAA, was encountered in the load_mpx command
   line.  No action was taken.

   A:     Type "help load_mpx" for use of the load_mpx command and try again.

   Message:
   admin_: stop_fnp: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator stop_mpx command.

   M:     An unknown argument, AAAA, was encountered in the stop_fnp command
   line.  This is an obsolete command.  No action was taken.

   A:     Type "help stop_mpx" for details of the stop_mpx command and try
   again.

   Message:
   admin_: stop_mpx: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator stop_mpx command.

   M:     An unknown argument, AAAA, was encountered in the stop_mpx command
   line.  No action was taken.

   A:     Type "help stop_mpx" for details of the stop_mpx command and try
   again.

   Message:
   admin_: shutdown_mpx: error: unknown argument AAAA

   S:     $as1

   T:     In response to an operator shutdown_mpx command.

   M:     An unknown argument, AAAA, was encountered in the shutdown_mpx
   command line.  No action was taken.

   A:     The shutdown_mpx command is the same as the dump_mpx command except
   that no dump is created.  Type "help dump_mpx" for command usage details
   and try again.

   Message:
   admin_: abs: error: unknown absentee command WXYZ

   S:	$as1

   T:	$response

   M:	The operator typed abs WXYZ where WXYZ was
   unrecognizable to the system.  No action was taken.

   A:	$tryagain

   Message:
   admin_: abs: error: The abs CCCC command can not be used before answering service startup.

   S:     $as1

   T:     In response to an operator abs command.

   M:     Only the "abs stop" command may be given before the answering service
   starts up.  This allows the operator to stop the absentee facility before
   the system finishes initialzation.

   A:     $tryagain

   Message:
   admin_: abs: stop: error: abs stop queue only works after answering service startup

   S:     $as1

   T:     In response to an operator abs stop queue command.

   M:     The answering service must complete initialization before the
   "abs stop queue" command can be used.

   A:     Allow the system to complete initialization and try again.

   Message:
   admin_: abs: stop: error: missing argument: queue to be stopped

   S:     $as1

   T:     In response to an operator "abs stop queue" command.

   M:     The "abs stop queue" command was entered without supplying the number
   of the queue to be stopped.

   A:     $tryagain

   Message:
   admin_: abs: stop: error: invalid queue to be stopped: DDDD

   S:     $as1

   T:     In response to an operator "abs stop queue" command.

   M:     The value of the queue number was not within the values of 1 and 4,
   inclusive.

   A:     $tryagain

   Message:
   admin_: abs: stop: error: unknown argument SSSS

   S:     $as1

   T:     In response to an operator "abs stop" command.

   M:     An unknown argument, SSSS, was supplied to the "abs stop" command.

   A:     Type "help abs" for details of the abs command and try again.

   Message:
   admin_: abs: stop: error: absentee stop in progress

   S:	$as1

   T:	$response

   M:	An abs start, abs stop, abs maxu, abs maxq, or
   down command was issued while the absentee facility was in the
   process of shutting down.

   A:	Wait for the message that all absentee processes have
   run to completion, then reissue the command.

   Message:
   admin_: abs: ABS_FUNCT: error: No job in absentee slot X (status= SSSS).

   S:     $as1

   T:     $response

   M:     The absentee slot absX has an entry status of SSSS indicating that no
   user is using it.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: Job in absentee slot X is not from user NAME.PROJ

   S:     $as1

   T:     $response

   M:     The job running in specified absentee slot of absX is not from
   specified user, NAME.PROJ.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: Job in absentee slot X does not match request ID YYYY

   S:     $as1

   T:     $response

   M:     The ID of the job running in specified absentee slot of absX does not
   match the specified ID of YYYY.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: Job in absentee slot X does not match absin path DIR_PATH>ENTRY_NAME

   S:     $as1

   T:     $response

   M:     The pathname of the absin of the job running in specified absentee
   slot of absX does not match the specified absin pathname.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: Job in absentee slot X does not match absin entry name SSSS

   S:     $as1

   T:     $response

   M:     The entry name SSSS of the absin of the job running in specified
   absentee slot of absX does not match the specified absin entry name.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: Job in absentee slot X is not from sender SSSS

   S:     $as1

   T:     $response

   M:     The sender of the absin of the job running in specified
   absentee slot of absX does not match the specified sender, SSSS.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: Job in absentee slot X is not from queue DDDD

   S:     $as1

   T:     $response

   M:     The queue of the absin of the job running in specified
   absentee slot of absX does not match the queue number DDDD.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: release: error: Job in absentee slot X is not suspended.

   S:     $as1

   T:     $response

   M:     The specified job running in
   absentee slot of absX is not suspended so a release does not apply.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: suspend: error: Job in absentee slot X is already suspended.

   S:     $as1

   T:     $response

   M:     The specified job running in 
   absentee slot of absX is already suspended and cannot be suspended again.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: release: error: Selection arguments matched no deferred or suspended absentee requests.

   S:     $as1

   T:     $response

   M:     No suspended or deferred job was found to release with the arguments
   supplied on the abs release command line.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: Selection arguments matched no running absentee jobs.

   S:     $as1

   T:     $response

   M:     No running job was found that matched the selection arguments
   supplied on the abs command line.

   A:     Recheck job specifications and try again.

   Message:
   admin_: abs: start: error: system coming down soon: no abs start

   S:     $as1

   T:     $response

   M:     The system is shutting down within 30 minutes so the absentee
   facility will not be started.

   A:     $ignore

   Message:
   admin_: abs: start: error: absentee already up

   S:	$as1

   T:	In response to an operator abs start command.

   M:	abs start was typed twice.  No action was taken on the second
   issuance of the command.

   A:	$ignore

   Message:
   admin_: abs: start: error: absentee not up. cannot restart queue X

   S:     $as1

   T:     $response

   M:     Cannot use the "abs start queue" command until the absentee facility
   has been started.

   A:     Issue the "abs start" command and try again.

   Message:
   admin_: abs: start: error: invalid queue to be restarted X

   S:     $as1

   T:     $response

   M:     An invalid queue number was specified in an operator
   "abs start queue" command line.  It must be between 1 and 4 inclusive.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: absentee not up

   S:	$as1

   T:	$response

   M:	An abs command was given, but
   the absentee facility had never been started up.  No action was
   taken on the command.

   A:	Type abs start to start up the absentee facility.

   Message:
   admin_: abs: qres: error: abs qres has invalid value: DDDD

   S:     $as1

   T:     $response

   M:     An invalid qres argument was detected in an operator "abs qres"
   command.  The argument must be "auto" or a positive decimal number.

   A:     $tryagain

   Message:
   admin_: abs: cpu_limit: error: Usage is: "abs cpu_limit l1,l2,l3,l4" (limits in seconds)

   S:     $as1

   T:     $response

   M:     Informative message that is displayed when an operator
   "abs cpu_limit" command without arguments is entered.

   A:     $tryagain

   Message:
   admin_: abs: list: error: The absN argument cannot be used when absentee is not up.

   S:     $as1

   T:     $reponse

   M:     Cannot use the "absN" argument to select absentee jobs to list until
   the absentee facility has been started.

   A:     Use other job selection criteria or type "abs start" and try again.

   Message:
   admin_: abs: list: error: No job in absentee slot X.

   S:     $as1

   T:     $response

   M:     The absentee slot absX does not exist.

   A:     $tryagain

   Message:
   admin_: COMMAND: error: No FNP tag specified.

   S:	$as1

   T:	Response to an operator "load_fnp", "fdump_fnp", "dump_fnp",
   "start_fnp", or "stop_fnp" command.

   M:	The operator did not supply an FNP identifier.

   A:	$tryagain

   Message:
   admin_: COMMAND: error: No multiplexer specified.

   S:	$as1

   T:	Response to an operator "load_mpx", "dump_mpx", "start_mpx",
   "shutdown_mpx" or "stop_mpx" command.

   M:	The operator did not supply a multiplexer name.

   A:	$tryagain

   Message:
   admin_: COMMAND: error: Invalid FNP tag: X

   S:	$as1

   T:	Response to an operator "load_fnp", "fdump_fnp", "dump_fnp",
   "start_fnp", or "stop_fnp" command.

   M:	The supplied FNP tag was more than one character or was not between
   a-h inclusive.

   A:	$tryagain

   Message:
   admin_: abs: maxu: error: abs maxusers must be numeric or "auto": SSSS

   S:     $as1

   T:     $response

   M:     The argument, SSSS, to the operator "abs maxu" command was not a
   positive numeric or the string, "auto".  The numeric value is in tenths
   of a load unit.

   A:     $tryagain

   Message:
   admin_: abs: maxu: error: abs maxusers may not be negative: SSSS

   S:     $as1

   T:     $response

   M:     The argument, SSSS, to the operator "abs maxu" command was not a
   positive numeric or the string, "auto".  The numeric value is in tenths
   of a load unit.

   A:     $tryagain

   Message:
   admin_: abs: maxu: error: abs maxusers may not be greater than system maxusers: SSSS

   S:     $as1

   T:     $response

   M:     The argument, SSSS, to the operator "abs maxu" command cannot
   be greater than the maximum allowed users that can be on the system.

   A:     $tryagain

   Message:
   admin_: abs: maxq: error: abs maxqueue has invalid value: XXX

   S:	$as1

   T:	$response

   M:	An abs maxq or abs start command had as an argument
   something that was not a number, or was too big, or was a negative
   number.  No action is taken.

   A:	$tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: More than one specification of an attribute is present: SSSS

   S:     $as1

   T:     $response

   M:     The SSSS attribute has already been specified to select an
   absentee job on the operator abs command.  An attribute can only be
   used once.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: Invalid abs job selection argument: SSSS

   S:     $as1

   T:     $response

   M:     The job selection argument SSSS is not recognized as valid.

   A:     Type "help abs" for details of the abs command usage and try again.

   Message:
   admin_: abs: ABS_FUNCT: Invalid queue number DDDD

   S:     $as1

   T:     $response

   M:     The value after the -queue job selection argument is invalid.
   It must be the strings "fg" or "foreground" or a between the values of
   1 and 4, inclusive.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: Relative pathnames not allowed: SSSS

   S:     $as1

   T:     $response

   M:     The pathname of the absin was expected and it must be an absolute
   pathname, starting with a ">" character.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: No job selection arguments given.

   S:     $as1

   T:     $response

   M:     After processing the arguments on the "abs abs_funct" operator
   command, no job selection arguments were encountered.

   A:     Type "help abs" for details of the abs command usage and try again.

   Message:
   admin_: abs: ABS_FUNCT: error: User name must be given.

   S:     $as1

   T:     $response

   M:     The "abs ABS_FUNCT" operator command requires that a user name be
   supplied.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: User name (not ""*"") must be given.

   S:     $as1

   T:     $response

   M:     The "abs ABS_FUNCT" operator command requires that a user name be
   supplied.  Cannot use "*".

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: The absN argument is not valid.

   S:     $as1

   T:     $response

   M:     The "abs ABS_FUNCT" operator command cannot allow use of the absN
   argument for job selection.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: Personid NAME > 22 characters.

   S:     $as1

   T:     $response

   M:     The "abs ABS_FUNCT" operator command specified a user name that is
   longer than 22 characters.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: SSSS is not a valid Person.Project.

   S:     $as1

   T:     $response

   M:     The "abs ABS_FUNCT" operator command did not specify a valid
   Person.Project in the string SSSS.

   A:     $tryagain

   Message:
   admin_: abs: ABS_FUNCT: error: Projectid SSSS is longer than 9 characters.

   S:     $as1

   T:     $response

   M:     The "abs ABS_FUNCT" operator command incorrectly specified a
   project name that is longer than 9 characters.

   A:     $tryagain

   END MESSAGE DOCUMENTATION */

     end admin_;




		    as_.alm                         11/12/82  1404.2rew 11/12/82  1116.4       18009



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"
"	AS_ - answering service transfer vector
"
" Modified 750430 by PG to add as_$reset
" Modified 750519 by PG to delete unused as_$tty_xxx entries
" Modified June 1981 by T. Casey to add device_acct_(on off setup) entry points
" Modified August 1981 by E. N. Kittlitz to add dump_dont_use_mc as synonym for dump_mc, add set_as_dump_dir.

	name	as_

	entry	as_init
	entry	dialup_
	entry	dump
	entry	dump_dont_use_mc
	entry	dump_mc
	entry	set_as_dump_dir
	entry	go
	entry	reset
	entry	shut_ok
	entry	shutdown
	entry	startup
	entry	find_process
	entry	device_acct_on
	entry	device_acct_off
	entry	device_acct_setup
	entry	meter_enter
	entry	meter_exit
	entry	meter_exit_values
	entry	meter_init
	entry	meter_ptr

as_init:	tra	<as_init_>|[as_init]

reset:	tra	<asu_>|[reset]

startup:	tra	<as_init_>|[startup]

go:	tra	<as_init_>|[go]

shut_ok:	tra	<as_init_>|[check_shut_ok]

shutdown:	tra	<as_init_>|[shutdown]

dialup_:	tra	<dialup_>|[dialup_]

dump:	tra	<as_dump_>|[as_dump_]

dump_dont_use_mc:
	tra	<as_dump_>|[dont_use_mc]

dump_mc:	tra	<as_dump_>|[dump_mc]

set_as_dump_dir:
	tra	<as_dump_>|[set_as_dump_dir]

find_process:
	tra	<asu_>|[find_process]

device_acct_on:
	tra	<device_acct_>|[on]

device_acct_off:
	tra	<device_acct_>|[off]

device_acct_setup:
	tra	<device_acct_>|[setup]

meter_enter:
	tra	<as_meter_>|[enter]

meter_exit:
	tra	<as_meter_>|[exit]

meter_exit_values:
	tra	<as_meter_>|[exit_values]

meter_init:
	tra	<as_meter_>|[asmt_init]

meter_ptr:
	tra	<as_meter_>|[asmt_ptr]

	end




		    as_access_audit_.pl1            07/20/88  1251.6r w 07/19/88  1536.1      245835



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-07-23,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to correctly set the grant/deny flag in binary data of audit
     messages.
  2) change(86-09-11,Lippard), approve(85-12-30,MCR7326),
     audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200):
     Added entry points abs_command_login and abs_command_cancel.
  3) change(87-03-11,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
      A) Added login and logout entrypoints for Login Server use.
      B) Correct coding standard violations.
      C) Updated for change to user_table_entry.incl.pl1.
  4) change(87-05-20,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
      A) Change as_access_audit_$process to accept a negative action code to
         audit a DENIED operation.  0-action identifies the operation that
         failed.
  5) change(87-06-08,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
      A) Make $process correctly audit failed LOGIN attempts as being DENIED.
      B) Restructure all messages to have the same format and content.
      C) Change calling sequence of $channel entrypoint to accommodate
         DIALIN, DIALOUT and DIAL SYSTEM, and MNA connections.
  6) change(87-06-29,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
      A) Omit tag from LOGOUT audit message if it hasn't been filled in yet.
      B) Add tag to process CREATE/CONNECT/etc messages.
  7) change(87-07-15,GDixon), approve(87-07-15,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add AS_AUDIT_PROCESS_TERMINATE action to $process entrypoint.
  8) change(87-07-24,Dickson), approve(87-07-24,MCR7722),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Added three entry points for auditing access checks: dpg_buzzard,
     as_rqt_nt_pnt_chg, and asr_com_chnl_info_srvr.
  9) change(88-03-18,Parisek), approve(88-03-18,MCR7849),
     audit(88-03-22,Lippard), install(88-07-13,MR12.2-1047):
     Changed reference of ute.initial_ring to ute.lowest_ring when copying it
     to the ASIAAR.record.min_ring value.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo,ll79 */

as_access_audit_:
     procedure ();

/**** This program is the auditing module for the Answering Service.
      All programs which audit security-relevant actions should call
      this program to audit.  An exception to this is lg_ctl_, which
      due to the way it accumulates the audit information, is difficult
      to interface to as_access_audit_. */

/**** NOTE
      Since all of the messages logged by this module are described in
      AK50, the error message documentation requirement is waived.  */


/* Modification History:
   85-01-18 E. Swenson: Written.
   85-02-07 E. Swenson: Fixed bug which resulted in garbage in channel
   names.
*/

/* Parameters */

dcl  P_action fixed bin (17) parameter;
dcl  P_added_info char (*) parameter;
dcl  P_asrccip pointer parameter;
dcl  P_asrsp pointer parameter;
dcl  P_cdtep pointer parameter;
dcl  P_channel_audit_info_ptr pointer parameter;
dcl  P_code fixed bin (35) parameter;
dcl  P_dial_server_info_ptr ptr parameter;
dcl  P_dial_utep ptr parameter;			/* MNA ute for dialed terminal */
dcl  P_failed bit (1) aligned parameter;
dcl  P_name char (*) parameter;
dcl  P_request_id fixed bin (71) parameter;
dcl  P_target_process_utep ptr parameter;		/* pointer to ute we are trying to conect to */
dcl  P_utep pointer parameter;

/* Automatic */

dcl  1 ACAR aligned like as_channel_audit_record;
dcl  1 ADAR aligned like as_dial_service_audit_record;
dcl  1 ARH aligned like audit_record_header automatic;
dcl  1 ARHP aligned like audit_record_header_proxy automatic;
dcl  1 ASIAAR aligned like as_ia_audit_record_abs_proxy;
dcl  action fixed bin (17);				/* copy of P_action */
dcl  added_info char (128);				/* additional info for log message */
dcl  audit_record_size fixed bin automatic;
dcl  dial_utep ptr;
dcl  1 event_flags aligned like audit_event_flags automatic;
dcl  grant_sw bit (1) aligned;			/* whether the operation was a success or a failure */
dcl  mins fixed bin (35) automatic;
dcl  operation bit (36) aligned automatic;
dcl  secs fixed bin (35) automatic;
dcl  proc_type char (4) automatic;
dcl  request_id fixed bin (71) automatic;
dcl  severity fixed bin automatic;
dcl  target_utep ptr;


/* Based */

dcl  1 dial_ute aligned like ute based (dial_utep);	/* ute for dialed */
						/* MNA terminal  */
dcl  1 target_ute aligned like ute based (target_utep);	/* pointer to process's ute we are trying to connect to. */


/* External Entries */

dcl  sys_log_ entry options (variable);
dcl  sys_log_$binary entry options (variable);
dcl  sys_log_$error_log entry entry options (variable);


/* External Static */

dcl  (
     access_operations_$abs_command_cancel,
     access_operations_$abs_command_login,
     access_operations_$channel_attach,
     access_operations_$channel_detach,
     access_operations_$dial_system,
     access_operations_$dialid_start,
     access_operations_$dialid_stop,
     access_operations_$dialin,
     access_operations_$dialout,
     access_operations_$process_connect,
     access_operations_$process_create,
     access_operations_$process_destroy,
     access_operations_$process_disconnect,
     access_operations_$process_terminate,
     access_operations_$user_login,
     access_operations_$user_logout
     ) bit (36) aligned external;
dcl  error_table_$action_not_performed fixed bin (35) external static;


/* Constant */

dcl  AS_AUDIT_DATA_CLASS char (16) varying initial ("access_audit")
	internal static options (constant);
dcl  (
     DENIED initial ("0"b),
     GRANTED initial ("1"b)
     ) bit (1) aligned internal static options (constant);
dcl  ME char (32) initial ("as_access_audit_") internal static
	options (constant);
dcl  MILLION fixed bin (35) initial (1000000) internal static
	options (constant);
dcl  PROCESS_TYPES (-1:3) char (3)
	initial ("int", "???", "int", "abs", "dmn") internal static
	options (constant);
dcl  QNAME (0:4) char (4) internal static options (constant)
	initial ("Q FG", "Q 1", "Q 2", "Q 3", "Q 4");


/* Builtin */
dcl  (addr, after, before, divide, length, mod, null, reverse, rtrim, string,
     size, substr, unspec) builtin;
%page;
/* Program */

process:
     entry (P_utep, P_action, P_added_info);

	utep = P_utep;				/* get into automatic storage for efficiency */
	action = P_action;				/* ditto */

	if action < 0
	then do;					/* allow auditing */
	     grant_sw = DENIED;			/* of denials by */
	     action = -action;			/* negative      */
	end;					/* action	       */
	else grant_sw = GRANTED;

	if (action ^= AS_AUDIT_PROCESS_CREATE
	     & action ^= AS_AUDIT_PROCESS_DESTROY
	     & action ^= AS_AUDIT_PROCESS_CONNECT
	     & action ^= AS_AUDIT_PROCESS_DISCONNECT
	     & action ^= AS_AUDIT_PROCESS_TERMINATE)
	then do;
	     call sys_log_$error_log (SL_LOG_SILENT,
		error_table_$action_not_performed, ME,
		"Invalid action code ^d for as_access_audit_$process entrypoint.",
		action);
	     return;
	end;

	call FILL_IN_ARH (addr (ARH), grant_sw);

	if action = AS_AUDIT_PROCESS_CREATE
	then ARH.header.operation_code = access_operations_$process_create;
	else if action = AS_AUDIT_PROCESS_DESTROY
	then ARH.header.operation_code = access_operations_$process_destroy;
	else if action = AS_AUDIT_PROCESS_CONNECT
	then ARH.header.operation_code = access_operations_$process_connect;
	else if action = AS_AUDIT_PROCESS_DISCONNECT
	then ARH.header.operation_code =
		access_operations_$process_disconnect;
	else if action = AS_AUDIT_PROCESS_TERMINATE
	then ARH.header.operation_code =
		access_operations_$process_terminate;
	if action = AS_AUDIT_PROCESS_CREATE
	then do;
	     if ute.logout_type = "new_"
		| substr (ute.logout_type, 1, 2) = "np"
	     then added_info = "new_proc";
	     else added_info = "login";
	end;
	else if action = AS_AUDIT_PROCESS_DESTROY
	then do;
	     added_info = ute.logout_type;
	     if substr (added_info, 1, 2) = "np" | added_info = "new_"
	     then added_info = "new_proc";
	     else if added_info = "alar"
	     then added_info = "bump";
	     else if added_info = "dest"
	     then added_info = "destroy";
	end;
	else added_info = P_added_info;

	call sys_log_$binary (SL_LOG_SILENT, addr (ARH), size (ARH),
	     AS_AUDIT_DATA_CLASS,
	     "^a^[ DENIED^]^20t^[*^]^a.^a.^a ^a ^12.3b ^[(^a)^;^s^]",
	     AS_AUDIT_PROCESS_ACTIONS (action), ^grant_sw,
	     (ute.anonymous = 1), ute.person, ute.project, ute.tag,
	     ute.tty_name, ute.proc_id, (added_info ^= ""), added_info);
	return;
%page;
process_connect_denied:
     entry (P_utep, P_target_process_utep, P_added_info);

	utep = P_utep;
	target_utep = P_target_process_utep;
	added_info = P_added_info;

	call FILL_IN_ARH (addr (ARH), DENIED);
	ARH.header.operation_code = access_operations_$process_connect;

	call sys_log_$binary (SL_LOG_SILENT, addr (ARH), size (ARH),
	     AS_AUDIT_DATA_CLASS,
	     "CONNECT DENIED^20t^[*^]^a.^a ^a to ^[*^]^a.^a.^a ^12.3b (^a)",
	     (ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
	     (target_ute.anonymous = 1), target_utep -> ute.person,
	     target_ute.project, target_ute.tag, target_ute.proc_id,
	     added_info);
	return;
%page;
channel:
     entry (P_cdtep, P_dial_utep, P_utep, P_action, P_channel_audit_info_ptr,
	P_added_info);

	cdtep = P_cdtep;
	dial_utep = P_dial_utep;
	utep = P_utep;
	action = P_action;				/* action/success fail indicator */
	channel_audit_info_ptr = P_channel_audit_info_ptr;
	added_info = P_added_info;

	if action < 0
	then do;
	     grant_sw = DENIED;			/* negative actions are failures */
	     action = -action;
	end;
	else grant_sw = GRANTED;			/* positive actions are successes */

	if action ^= AS_AUDIT_CHANNEL_ATTACH
	     & action ^= AS_AUDIT_CHANNEL_DETACH
	     & action ^= AS_AUDIT_CHANNEL_DIALIN
	     & action ^= AS_AUDIT_CHANNEL_DIALOUT
	     & action ^= AS_AUDIT_CHANNEL_DIAL_SYSTEM
	then do;
	     call sys_log_$error_log (SL_LOG,
		error_table_$action_not_performed, ME,
		"Invalid action code ^d for as_access_audit_$channel entrypoint.",
		action);
	     return;
	end;

	call FILL_IN_ARH (addr (ACAR.header), grant_sw);

	if action = AS_AUDIT_CHANNEL_ATTACH
	then ACAR.header.operation_code = access_operations_$channel_attach;
	else if action = AS_AUDIT_CHANNEL_DETACH
	then ACAR.header.operation_code = access_operations_$channel_detach;
	else if action ^= AS_AUDIT_CHANNEL_DIALIN
	then ACAR.header.operation_code = access_operations_$dialin;
	else if action ^= AS_AUDIT_CHANNEL_DIALOUT
	then ACAR.header.operation_code = access_operations_$dialout;
	else if action ^= AS_AUDIT_CHANNEL_DIAL_SYSTEM
	then ACAR.header.operation_code = access_operations_$dial_system;

	if channel_audit_info.valid.user_validation_level
	then ACAR.header.subject.ring =
		channel_audit_info.user_validation_level;
	else ACAR.header.subject.ring = 0;
	ACAR.record.type = AAB_channel;
	ACAR.record.version = AS_AUDIT_RECORD_CHN_VERSION_1;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This entrypoint may be called by MCS user control (dial_ctl_) or by MNA   */
/* ls user control (uc_dial_).				       */
/*							       */
/* MCS passes a cdte pointer if there is a channel associated with the       */
/* attach, detach, dial, dial system or dial_out request.  For dial	       */
/* requests, if dial -user was given, then the authenticated user's	       */
/* person.project is stored in the cdte along with the channel attributes.   */
/*							       */
/* MNA passes a dial_ute pointer if there is an authenticated user	       */
/* associated with the dial, dial system or login -operator request.	       */
/*							       */
/* In all cases the ute pointer identifies the process doing the attach,     */
/* detach or dial_out; or the target process of a dial, dial system or login */
/* -operator request.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if cdtep = null () & dial_utep = null ()	/* No auth user  */
	then do;
	     ACAR.record.flags.channel_info_valid = "0"b;
	     ACAR.record.flags.current_access_class_valid =
		channel_audit_info.valid.access_class;
	     ACAR.record.pad1 = ""b;
	     ACAR.record.channel_name = channel_audit_info.channel_name;
	     if channel_audit_info.valid.access_class
	     then ACAR.record.current_access_class =
		     channel_audit_info.access_class;
	     else ACAR.record.current_access_class = ""b;
	     if channel_audit_info.valid.access_class_range
	     then ACAR.record.access_class_range =
		     channel_audit_info.access_class_range;
	     else ACAR.record.access_class_range =
		     ACAR.record.current_access_class;
	     ACAR.record.current_service_type = 0;
	     ACAR.record.service_type = 0;
	     ACAR.record.terminal_type = "";
	     ACAR.record.authenticated_user.personid = "";
	     ACAR.record.authenticated_user.projectid = "";
	     ACAR.record.authenticated_user.pad2 = ""b;
	end;
%page;
	else if cdtep ^= null ()
	then do;					/* attach, detach */
	     ACAR.record.flags.channel_info_valid = "1"b; /* dial chn known */
	     ACAR.record.flags.current_access_class_valid =
		cdte.dialup_flags.current_access_class_valid;
	     ACAR.record.pad1 = ""b;
	     ACAR.record.channel_name = cdte.name;
	     ACAR.record.current_access_class = cdte.current_access_class;
	     ACAR.record.access_class_range = cdte.access_class;
	     ACAR.record.current_service_type = cdte.current_service_type;
	     ACAR.record.service_type = cdte.service_type;
	     ACAR.record.terminal_type = cdte.current_terminal_type;
	     ACAR.record.authenticated_user.personid = cdte.user_name.person;
	     ACAR.record.authenticated_user.projectid =
		cdte.user_name.project;
	     ACAR.record.authenticated_user.pad2 = ""b;
	end;
	else if dial_utep ^= null ()
	then do;					/* dial, 	       */
						/* login -op     */
	     ACAR.record.flags.channel_info_valid = "1"b; /* auth user info */
	     ACAR.record.flags.current_access_class_valid = "1"b;
	     ACAR.record.pad1 = ""b;
	     ACAR.record.channel_name = dial_ute.tty_name;
	     if channel_audit_info.valid.access_class
	     then ACAR.record.current_access_class =
		     channel_audit_info.access_class;
	     else ACAR.record.current_access_class = ""b;
	     if channel_audit_info.valid.access_class_range
	     then ACAR.record.access_class_range =
		     channel_audit_info.access_class_range;
	     else ACAR.record.access_class_range =
		     ACAR.record.current_access_class;
	     ACAR.record.current_service_type = 0;
	     ACAR.record.service_type = 0;
	     ACAR.record.terminal_type = dial_ute.terminal_type;
	     ACAR.record.authenticated_user.personid = rtrim(dial_ute.person);
	     ACAR.record.authenticated_user.projectid = rtrim(dial_ute.project);
	     ACAR.record.authenticated_user.pad2 = ""b;
	end;

	call sys_log_$binary (SL_LOG_SILENT, addr (ACAR), size (ACAR),
	     AS_AUDIT_DATA_CLASS,
	     "^a^[ DENIED^]^20t^[^a.^a ^;^s^s^]channel ^a ^a ^[*^]^a.^a.^a ^12.3b^[ ^a=^a^;^s^s^]^[ (^a)^]",
	     AS_AUDIT_CHANNEL_ACTIONS (action), ^grant_sw,
	     ACAR.record.authenticated_user.personid ^= "",
	     ACAR.record.authenticated_user.personid,
	     ACAR.record.authenticated_user.projectid,
	     ACAR.record.channel_name, AS_AUDIT_CHANNEL_DIRECTION (action),
	     (ute.anonymous = 1), ute.person, ute.project, ute.tag,
	     ute.proc_id, channel_audit_info.valid.service_info,
	     AS_AUDIT_CHANNEL_SERVICE_INFO (action),
	     channel_audit_info.service_info, (added_info ^= ""), added_info)
	     ;
	return;
%page;
dialid:
     entry (P_utep, P_action, P_dial_server_info_ptr, P_added_info);

	utep = P_utep;
	action = P_action;				/* action/success fail indicator */
	added_info = P_added_info;
	dial_server_info_ptr = P_dial_server_info_ptr;
	if action < 0
	then do;
	     grant_sw = DENIED;			/* negative actions are failures */
	     action = -action;
	end;
	else grant_sw = GRANTED;			/* positive actions are successes */

	if action ^= AS_AUDIT_DIALID_START & action ^= AS_AUDIT_DIALID_STOP
	then do;
	     call sys_log_$error_log (SL_LOG_SILENT,
		error_table_$action_not_performed, ME,
		"Invalid action code ^d for as_access_audit_$dialid entrypoint.",
		action);
	     return;
	end;

	call FILL_IN_ARH (addr (ADAR.header), grant_sw);

	if action = AS_AUDIT_DIALID_START
	then ADAR.header.operation_code = access_operations_$dialid_start;
	else ADAR.header.operation_code = access_operations_$dialid_stop;

	ADAR.header.subject.ring = dial_server_info.server_ring;

	ADAR.record.type = AAB_dial_service;
	ADAR.record.version = AS_AUDIT_RECORD_DIALID_VERSION_1;
	ADAR.record.dial_server_ring = dial_server_info.server_ring;
	ADAR.record.flags.registered_server = dial_server_info.registered;
	ADAR.record.flags.privileged_server = dial_server_info.privileged;
	ADAR.record.dial_qualifier = dial_server_info.dial_qualifier;

	call sys_log_$binary (SL_LOG_SILENT, addr (ADAR), size (ADAR),
	     AS_AUDIT_DATA_CLASS,
	     "DIALID^[ DENIED^]^20t^[start^;stop^] service for ^[*^]^a.^a.^a ^12.3b id=^a^[ (^a)^]",
	     ^grant_sw, (action = AS_AUDIT_DIALID_START),
	     (ute.anonymous = 1), ute.person, ute.project, ute.tag,
	     ute.proc_id, dial_server_info.dial_qualifier,
	     (added_info ^= ""), added_info);
	return;
%page;
abs_command_cancel:
     entry (P_utep, P_asrsp, P_request_id, P_failed);

	utep = P_utep;
	as_request_sender_ptr = P_asrsp;
	request_id = P_request_id;
	grant_sw = ^P_failed;

	ARHP.header.type = ARH_TYPE_PROXY;
	ARHP.header.version = ACCESS_AUDIT_HEADER_VERSION_3;
	string (ARHP.header.flags) = ""b;
	ARHP.header.flags.subject_is_process = "1"b;
	ARHP.header.operation_code = access_operations_$abs_command_cancel;
	unspec (event_flags) = ""b;
	event_flags.special_op = "1"b;
	event_flags.grant = grant_sw;
	ARHP.header.event_flags = unspec (event_flags);
	ARHP.header.session_uid = ute.session_uid;

/* Binary info for the absentee process for which a cancellation request
   has been sent. */
	ARHP.subjects (1).person =
	     substr (ute.person, 1, length (ARHP.subjects (1).person));
	ARHP.subjects (1).project =
	     substr (ute.project, 1, length (ARHP.subjects (1).project));
	ARHP.subjects (1).tag = ute.tag;
	ARHP.subjects (1).ring = ute.initial_ring;
	ARHP.subjects (1).anonymous = (ute.anonymous = 1);
	ARHP.subjects (1).pad3 = ""b;
	ARHP.subjects (1).process_id = ute.proc_id;
	ARHP.subjects (1).authorization = ute.process_authorization;
	ARHP.subjects (1).authorization_range (1) =
	     ute.process_authorization_range (1);
	ARHP.subjects (1).authorization_range (2) =
	     ute.process_authorization_range (2);

/* Binary info for the process requesting the cancellation. */
	ARHP.subjects (2).person = before (as_request_sender.group_id, ".");
	ARHP.subjects (2).project =
	     before (after (as_request_sender.group_id, "."), ".");
	ARHP.subjects (2).tag =
	     after (after (as_request_sender.group_id, "."), ".");
	ARHP.subjects (2).ring = as_request_sender.validation_level;
	ARHP.subjects (2).anonymous =
	     (ARHP.subjects (2).person = "anonymous");
	ARHP.subjects (2).pad3 = ""b;
	ARHP.subjects (2).process_id = as_request_sender.process_id;
	ARHP.subjects (2).authorization = as_request_sender.authorization;
	ARHP.subjects (2).authorization_range (1) =
	     as_request_sender.authorization;
	ARHP.subjects (2).authorization_range (2) =
	     as_request_sender.max_authorization;

	call sys_log_$binary (SL_LOG_SILENT, addr (ARHP), size (ARHP),
	     AS_AUDIT_DATA_CLASS,
	     "ABS CANCEL^[ DENIED^]^20t^[*^]^a.^a.^a ^a ^12.3b (car by ^[*^]^a)",
	     ^grant_sw, (ute.anonymous = 1), ute.person, ute.project,
	     ute.tag, ute.tty_name, ute.proc_id, ARHP.subjects (2).anonymous,
	     as_request_sender.group_id);
	return;
%page;
abs_command_login:
     entry (P_asrsp);

	as_request_sender_ptr = P_asrsp;

	operation = access_operations_$abs_command_login; /* make pcref    */
						/* find where op */
						/* being audited */

	call sys_log_ (SL_LOG_SILENT,
	     "ABS LOGIN^20trequested by ^a Level=^d",
	     as_request_sender.group_id, as_request_sender.validation_level);
	return;
%page;
login:
     entry (P_utep, P_added_info);

	utep = P_utep;
	added_info = P_added_info;
	grant_sw = (ute.login_result = 0);

	unspec (ASIAAR) = ""b;
	call FILL_IN_ARH (addr (ASIAAR.header), grant_sw);
	ASIAAR.header.operation_code = access_operations_$user_login;

	if ute.process_type = PT_ABSENTEE
	then if ute.abs_attributes.proxy
	     then ASIAAR.record.type = AAB_ia_abs_proxy;
	     else ASIAAR.record.type = AAB_ia_abs;
	else ASIAAR.record.type = AAB_ia_int_dmn;

	ASIAAR.record.version = AS_AUDIT_RECORD_IA_VERSION_1;
	ASIAAR.record.process_type = ute.process_type;
	ASIAAR.record.min_ring = ute.lowest_ring;
	ASIAAR.record.max_ring = ute.highest_ring;
	ASIAAR.record.attributes = ute.at;
	ASIAAR.record.audit_flags = ute.audit;
	ASIAAR.record.channel = ute.tty_name;
	ASIAAR.record.terminal_type = ute.terminal_type;
	ASIAAR.record.answerback = ute.tty_id_code;
	ASIAAR.absentee_input_path = ute.input_seg;

	ASIAAR.proxy_user =
	     rtrim (ute.proxy_person) || "." || ute.proxy_project;

	proc_type = PROCESS_TYPES (ute.process_type);
	if ute.process_type = PT_ABSENTEE
	then do;
	     proc_type = QNAME (ute.queue);
	     if ute.abs_attributes.proxy
	     then audit_record_size = size (as_ia_audit_record_abs_proxy);
	     else audit_record_size = size (as_ia_audit_record_abs);
	end;
	else audit_record_size = size (as_ia_audit_record_int_dmn);

	if grant_sw
	then severity = SL_LOG;
	else severity = SL_LOG_SILENT;

	call sys_log_$binary (severity, addr (ASIAAR), audit_record_size,
	     AS_AUDIT_DATA_CLASS,
	     "LOGIN^[ DENIED^]^20t^[*^]^a.^a ^a ^a^[ [^a]^;^s^]^[ (^a)^;^]",
	     ^grant_sw, (ute.anonymous = 1), ute.person, ute.project,
	     proc_type, ute.tty_name, (ute.process_type = PT_ABSENTEE),
	     Abs_Entry_Name (ute.input_seg), (added_info ^= ""), added_info);
	return;
%page;
logout:
     entry (P_utep, P_added_info);

	utep = P_utep;
	added_info = P_added_info;
	secs = divide (ute.cpu_usage, MILLION, 35, 0);
	mins = divide (secs, 60, 35, 0);
	secs = mod (secs, 60);

	proc_type = PROCESS_TYPES (ute.process_type);
	if ute.process_type = PT_ABSENTEE
	then proc_type = QNAME (ute.queue);

	call FILL_IN_ARH (addr (ASIAAR.header), GRANTED);

	ASIAAR.header.operation_code = access_operations_$user_logout;

	call sys_log_$binary (SL_LOG, addr (ASIAAR.header),
	     size (audit_record_header), AS_AUDIT_DATA_CLASS,
	     "LOGOUT^20t^[*^]^a.^a^[.^a^;^s^] ^a ^a ^3d:^2d $^.2f (^a)",
	     (ute.anonymous = 1), ute.person, ute.project, (ute.tag ^= ""),
	     ute.tag, proc_type, ute.tty_name, mins, secs, ute.session_cost,
	     added_info);
	return;
%page;
FILL_IN_ARH:
     procedure (P_ahrp, P_grant_sw);

dcl  P_ahrp pointer parameter;
dcl  P_grant_sw bit (1) aligned parameter;
dcl  p pointer automatic;

	p = P_ahrp;				/* get pointer to audit_record_header */
	p -> audit_record_header.header.type = ARH_TYPE_NO_PROXY;
	p -> audit_record_header.header.version =
	     ACCESS_AUDIT_HEADER_VERSION_3;
	string (p -> audit_record_header.header.flags) = ""b;
	p -> audit_record_header.header.flags.subject_is_process = "1"b;

/* Here, we really should have more information passed to us about whether
   this is a privileged operation or not.  We could set the priv flag if
   we had this information. */

	unspec (event_flags) = ""b;
	event_flags.special_op = "1"b;
	event_flags.grant = P_grant_sw;
	p -> audit_record_header.header.event_flags = unspec (event_flags);
	p -> audit_record_header.header.session_uid = ute.session_uid;
	p -> audit_record_header.subject.person =
	     substr (ute.person, 1,
	     length (p -> audit_record_header.subject.person));
	p -> audit_record_header.subject.project =
	     substr (ute.project, 1,
	     length (p -> audit_record_header.subject.project));
	p -> audit_record_header.subject.tag = ute.tag;
	p -> audit_record_header.subject.ring = ute.initial_ring;
						/* updated later */
	p -> audit_record_header.subject.anonymous = (ute.anonymous = 1);
	p -> audit_record_header.subject.pad3 = ""b;
	p -> audit_record_header.subject.process_id = ute.proc_id;
	p -> audit_record_header.subject.authorization =
	     ute.process_authorization;
	p -> audit_record_header.subject.authorization_range =
	     ute.process_authorization_range;
	return;

     end FILL_IN_ARH;
%page;
Abs_Entry_Name:
     procedure (P_pathname) returns (char (*));

/**** This internal procedure returns the entryname portion of the absentee
      pathname minus the ".absin" suffix. */

dcl  P_pathname char (*) parameter;
dcl  dirname char (168);
dcl  entryname char (32);
dcl  code fixed bin (35);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));

	call expand_pathname_ (P_pathname, dirname, entryname, code);
	if code ^= 0
	then return ("-invalid-");
	else return (reverse (after (reverse (entryname), "nisba.")));

     end Abs_Entry_Name;
%page;
as_rqt_nt_pnt_chg:
     entry (P_name, P_asrsp, P_code);

	as_request_sender_ptr = P_asrsp;

	call sys_log_$error_log (SL_LOG_SILENT, P_code, P_name,
	     "^[GRANTED^;Rejected^] NOTE_PNT_CHANGE request from ^a.^[  Validation level (^d) not Ring-1.^]",
	     (P_code = 0), as_request_sender.group_id, (P_code ^= 0),
	     as_request_sender.validation_level);

	return;

%page;
asr_com_chn_info_srvr:
     entry (P_name, P_asrsp, P_asrccip, P_code);

	as_request_sender_ptr = P_asrsp;
	asr_com_channel_info_ptr = P_asrccip;

	call sys_log_$error_log (SL_LOG, P_code, ME,
	     "^[GRANTED^;DENIED^] com_channel_info request for ^a on channel ^a.",
	     (P_code = 0), as_request_sender.group_id,
	     asr_com_channel_info.channel_name);

	return;


%page;
dpg_buzzard:
     entry (P_name, P_asrsp, P_code);

	as_request_sender_ptr = P_asrsp;

	call sys_log_$error_log (SL_LOG_SILENT, P_code, P_name,
	     "^[GRANTED^;DENIED^] process_termination_monitor request by ^a.",
	     (P_code = 0), as_request_sender.group_id);

	return;

/* Includes */

/* format: off */
%page; %include access_audit_binary_def;
%page; %include access_audit_bin_header;
%page; %include access_audit_eventflags;
%page; %include as_audit_structures;
%page; %include as_request_header;
%page; %include as_request_sender_;
%page; %include asr_com_channel_info;
%page; %include author_dcl;
%page; %include cdt;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
/* format: on */

     end as_access_audit_;




		    as_add_admin_acl_.pl1           07/13/88  1112.8r w 07/13/88  0941.4       59463



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/* AS_ADD_ADMIN_ACL_

   Program to put all system administrators and all project administrators
   on the ACL of some entry.

   PG 741121
   Modified 750214 (Valentine's Day) by PG to add instance tag to user names.
   Modified 750813 by PG to watch out for null system administrator names.
*/

as_add_admin_acl_:
     procedure (bv_dname, bv_ename, bv_sat_ptr, bv_acl_program, bv_mode, bv_code);

/* parameters */

declare (bv_dname char (*),
         bv_ename char (*),
         bv_sat_ptr ptr,
         bv_acl_program variable entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
         bv_mode bit (*),
         bv_code fixed bin (35)) parameter;

/* automatic */

declare (satp, satep) ptr,
        (satx, adminx, aclx, n_dir_acls, n_seg_acls) fixed bin,
         seg bit (1) aligned,
         name char (32),
         code fixed bin (35);

/* builtins */

declare (addr, length, reverse, substr, verify) builtin;

/* entries */

declare  sys_log_$error_log entry options (variable);

/* external static */

declare  error_table_$argerr fixed bin (35) external static;

/* include files */

%include sat;
%include user_attributes;

/* program */

	satp = bv_sat_ptr;
	n_seg_acls = (4 * satp -> sat.n_projects) + 2;	/* maximum number of proj admins + 2 sys admins */
	n_dir_acls = 0;
	seg = "1"b;
	go to join;

as_add_admin_acls_$dir:
	entry (bv_dname, bv_ename, bv_sat_ptr, bv_acl_program, bv_mode, bv_code);

	satp = bv_sat_ptr;
	n_dir_acls = (4 * satp -> sat.n_projects) + 2;
	n_seg_acls = 0;
	seg = "0"b;

join:
	begin;					/* allocate the acl structure */

declare 1 directory_acls aligned dim (n_dir_acls) automatic,
        2 access_name char (32),
        2 modes bit (36),
        2 status_code fixed bin (35);

declare 1 segment_acls aligned dim (n_seg_acls) automatic,
        2 access_name char (32),
        2 modes bit (36),
        2 zero_pad bit (36),
        2 status_code fixed bin (35);

	     aclx = 1;
	     do satx = 1 to sat.current_size;		/* loop thru all used entries */
		satep = addr (sat.project (satx));	/* ptr to project entry */
		if project.state = 1 then do;		/* in use */
		     do adminx = 1 to 4 while (project.admin (adminx).userid ^= "");
			if seg then do;
			     segment_acls (aclx).access_name = add_tag (project.admin (adminx).userid);
			     segment_acls (aclx).modes = bv_mode;
			     segment_acls (aclx).zero_pad = ""b;
			     segment_acls (aclx).status_code = 0;
			end;
			else do;
			     directory_acls (aclx).access_name = add_tag (project.admin (adminx).userid);
			     directory_acls (aclx).modes = bv_mode;
			     directory_acls (aclx).status_code = 0;
			end;
			aclx = aclx + 1;
		     end;
		end;
	     end;

	     do adminx = 1 to 2 while (sat.system_admin (adminx) ^= "");
		if seg then do;
		     segment_acls (aclx).access_name = add_tag (sat.system_admin (adminx));
		     segment_acls (aclx).modes = bv_mode;
		     segment_acls (aclx).zero_pad = ""b;
		     segment_acls (aclx).status_code = 0;
		end;
		else do;
		     directory_acls (aclx).access_name = add_tag (sat.system_admin (adminx));
		     directory_acls (aclx).modes = bv_mode;
		     directory_acls (aclx).status_code = 0;
		end;
		aclx = aclx + 1;
	     end;
	     aclx = aclx - 1;			/* normalize to number used */

	     if seg then call bv_acl_program (bv_dname, bv_ename, addr (segment_acls), aclx, code);
	     else call bv_acl_program (bv_dname, bv_ename, addr (directory_acls), aclx, code);
	     if code ^= 0 then do;
		if code = error_table_$argerr then do;	/* oh, damn! */
		     do adminx = 1 to aclx;

			if seg then do;
			     code = segment_acls (adminx).status_code;
			     name = segment_acls (adminx).access_name;
			end;
			else do;
			     code = directory_acls (adminx).status_code;
			     name = directory_acls (adminx).access_name;
			end;

			if code ^= 0 then
			     call sys_log_$error_log (2, code,
			     "as_add_admin_acl_", "Could not add ^a to ACL of ^a>^a",
			     name, bv_dname, bv_ename);
		     end;
		end;
		else call sys_log_$error_log (2, code, "as_add_admin_acl_",
		     "Could not add to ACL of ^a>^a", bv_dname, bv_ename);

		bv_code = code;
		return;
	     end;
	end;					/* the begin block */
	bv_code = 0;				/* a-ok */
	return;

	

/* Internal procedure to add an instance tag to an administrator name */

add_tag:
	procedure (bv_access_name) returns (char (32));

/* parameters */

declare  bv_access_name char (*);

/* automatic */

declare  access_name char (32);
declare  n fixed bin;

/* program */

	     access_name = bv_access_name;		/* expand to char (32) */

	     n = length (access_name) - verify (reverse (access_name), " ") + 1;
						/* find length of access_name */

	     substr (access_name, n + 1, 2) = ".*";	/* splat */

	     return (access_name);

	end add_tag;

/* BEGIN MESSAGE DOCUMENTATION

Message:
as_add_admin_acl_: ERROR_MESSAGE. Could not add PGID to ACL of PATH.

S:	as (severity2)

T:	Answering Service initialization, or while the system is running.

M:	An error occurred while trying to rebuild the access control list (ACL) on PATH where:

ERROR_MESSAGE  is an error_table_ message
.br
PGID           is a process group id
.br
PATH           is a full pathname

A:	Manually give PGID read access (or status permission) to PATH.


Message:
as_add_admin_acl_: ERROR_MESSAGE. Could not add to ACL of PATH.

S:	as (severity2)

T:	Answering Service initialization, or while the system is running.

M:	Some fatal error occurred while rebuilding the access control list (ACL) of PATH.  ERROR_MESSAGE is an
error_table_ message and PATH is the full pathname of a segment or a directory.

A:	$contact
The operation that caused the error must be determined and the operation repeated
after correction.

   END MESSAGE DOCUMENTATION */

     end as_add_admin_acl_;




		    as_any_other_handler_.pl1       11/29/84  1039.5r w 11/28/84  1141.1       27927



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
as_any_other_handler_:
     procedure (P_caller, P_cleanup_proc, P_cleanup_label, P_error_label);

/* *	AS_ANY_OTHER_HANDLER_
   *
   *	This procedure is used to handle unexpected conditions in the
   *	Answering Service.	It is designed to be called as follows:
   *
   *	on condition (any_other)
   *	     call as_any_other_handler_ ("name-of-calling-procedure",
   *		cleanup_procedure_for_owning_procedure,
   *		exit_label_for_exit_after_cleanup,
   *		exit_label_for_exit_without_cleanup);
   *
   *	It was abstracted from syserr_log_man_ in order to keep that
   *	procedure a little simpler.
   *
   *	Modification history:
   *	84-10-15, W. Olin Sibert: Moved from syserr_log_man_
   */

declare	P_caller char (*) parameter;
declare	P_cleanup_proc entry () parameter;
declare	P_cleanup_label label parameter;
declare	P_error_label label parameter;

declare	code fixed bin (35);
declare	call_cleanup_procedure bit (1);
declare	continue_sw bit (1);
declare	non_local_exit bit (1);

declare 1 cond_info aligned like condition_info automatic;

declare	as_check_condition_ entry (char (*), bit (1), bit (1));
declare	as_dump_ entry (char (*));
declare	continue_to_signal_ entry (fixed bin (35));
declare	find_condition_info_ entry (pointer, pointer, fixed bin (35));
declare	sys_log_ entry options (variable);
declare	sys_log_$error_log entry options (variable);

declare	WHOAMI char (32) internal static options (constant) init ("as_any_other_handler_");
declare	SYS_LOG_TYPE fixed bin internal static options (constant) init (1);

declare	any_other condition;

declare  (addr, null) builtin;

/* */

	call_cleanup_procedure = "1"b;
	goto HANDLER_COMMON;



as_any_other_handler_$no_cleanup:
     entry (P_caller, P_error_label);

	call_cleanup_procedure = "0"b;


HANDLER_COMMON:
	on condition (any_other)			/* Not a thing that can be done */
	     goto P_error_label;

	cond_info.version = condition_info_version_1;
	call find_condition_info_ (null (), addr (cond_info), code);
	if (code ^= 0) then do;
	     call sys_log_$error_log (SYS_LOG_TYPE, code, WHOAMI,
		"Cannot get condition information.");
	     goto P_error_label;
	     end;

	call as_check_condition_ ((cond_info.condition_name), continue_sw, non_local_exit);
	if continue_sw then do;			/* ONLY way to "return" from this procedure */
	     call continue_to_signal_ ((0));
	     return;
	     end;

	call sys_log_ (SYS_LOG_TYPE, "^a: Condition ^a signalled.",
	     P_caller, cond_info.condition_name);

	call as_dump_ (P_caller);

	if ^call_cleanup_procedure then		/* None supplied by caller */
	     goto P_error_label;

	else if non_local_exit then do;
	     call P_cleanup_proc ();
	     goto P_cleanup_label;
	     end;

	else goto P_error_label;

%page; %include condition_info;

	end as_any_other_handler_;




		    as_check_condition_.pl1         08/04/87  1457.4rew 08/04/87  1221.9       20250



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-12-05,Swenson), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Modified to pass the command_error and command_question conditions.
                                                   END HISTORY COMMENTS */


/* format: style4 */

as_check_condition_: proc (a_condition, a_continue, a_non_local);

/* Answering Service utility to do the right thing by "ucs" handlers. */
/* 82-09-24 wrought  by E. N. Kittlitz. */
/* 82-12-02 modified by E. N. Kittlitz. don't continue on command_question, command_error, command_abort_ */
/* 1985-01-02, BIM: added signal_io_ to condition list. */

dcl  a_condition char (*);				/* condition name */
dcl  a_continue bit (1) unaligned;			/* set "1"b if caller should pass on condition */
dcl  a_non_local bit (1) unaligned;			/* set "1"b if this is an unwinder */

dcl  i fixed bin;

dcl  hbound builtin;

dcl  non_local_names (3) char (20) unaligned static options (constant) init (
	"cleanup",
	"finish",
	"program_interrupt");

dcl  continue_names (12) char (20) unaligned static options (constant) init (
	"alrm",
	"cput",
	"command_error",
	"command_question",
	"endfile",
	"endpage",
	"mme2",
	"quit",
	"signal_io_",
	"storage",
	"sus_",
	"trm_");
%page;
	do i = 1 to hbound (non_local_names, 1);
	     if a_condition = non_local_names (i) then do;
		a_continue = "0"b;			/* it's up to you */
		a_non_local = "1"b;			/* but I'd like to go further */
		return;
	     end;
	end;

	do i = 1 to hbound (continue_names, 1);
	     if a_condition = continue_names (i) then do;
		a_continue = "1"b;			/* don't bother looking */
		a_non_local = "0"b;
		return;
	     end;
	end;

	a_continue, a_non_local = "0"b;
	return;

     end as_check_condition_;




		    as_dump_.pl1                    10/28/88  1411.3r w 10/28/88  1302.2      115398



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(87-03-11,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.
  3) change(87-05-06,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Disable stringsize checking when assigning input parameter.  Caller may
     have passed a long string.
                                                   END HISTORY COMMENTS */

/* format: style4 */
as_dump_: proc (dumpid);

/* AS_DUMP_ - program to take off line dump of answering service stack.
   Modified 750210 by PG to try to cleanup after aborted dump.
   Modified January 1978 by T. Casey to try once more after an aborted dump so we can see why it aborted.
   Modified August 1981 by E. N. Kittlitz to not use mc until as_init_ says
   it is ok.
   Modified May 1982 by E. N. Kittlitz. New AS initialization.
   Modified Spetember 1982 by E. N. Kittlitz. USE static_dump_dir.
   Modified 1985-03-06, BIM: call trace_stack_$hregs
   Modified 1985-03-18, E. Swenson to pass signal_io_ condition.
*/

/* parameter */

dcl  dumpid char (*) parameter;			/* anything caller wants to say */

/* Automatic */

dcl  abort label;					/* escape route */
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  datstr char (24);
dcl  dir char (168);				/* where the dump goes */
dcl  dir_dumpid char (256) varying;			/* dump dir + dumpid for messages */
dcl  doing_stack_trace bit (1) aligned init (""b);
dcl  ec fixed bin (35);
dcl  error_entry entry variable options (variable);
dcl  i fixed bin;
dcl  iocbp ptr;
dcl  iqct fixed bin;
dcl  outname char (32);
dcl  quota fixed bin;
dcl  sp ptr;
dcl  taccsw fixed bin (1);
dcl  trp fixed bin (35);
dcl  tup bit (36) aligned;
dcl  ucs_recursion fixed bin initial (0);		/* trouble in as_dump_ counter */
dcl  use_r0m bit (1) aligned;				/* use phcs_ ("1"b)or use the Message Coord ("0"b) */
dcl  used fixed bin;

/* internal static */

dcl  ENOUGH fixed bin int static init (64);
dcl  STREAM char (32) int static init ("as_dump_stream_");
dcl  static_dump_dir char (168) static internal init ("");

/* based */

dcl  arg char (argl) based (argp);

/* entries */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  condition_ entry (char (*), entry);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$stack_frame_ptr entry (ptr);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  dprint_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$quota_get entry (char (*), fixed bin, fixed bin (35), bit (36) aligned, fixed bin, fixed bin (1), fixed bin, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  phcs_$ring_0_message entry (char (*));
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  trace_stack_$hregs entry (ptr, fixed bin, fixed bin, char (32) aligned, fixed bin);

/* builtins */

dcl  (addr, clock, null, rtrim, substr) builtin;

/* ====================================================== */

/* When taking an as_dump, we don't want to use portions of the AS of which
   we are not certain. During initialization, our problems might be due
   to something in the message coordinator, so we elect to not use the mc.
   After as_init_ has run, and sc_stat_$Multics is set at the end of initialization,
   we will avoid the MC only when we are dumping the MC itself (indicated by
   the user calling the dump_mc entry. */

	use_r0m = ^sc_stat_$Multics;			/* as as_init_ goes... */
	go to common;

dont_use_mc:					/* use ring_0_message for all console messages */
dump_mc:						/* this entry-name retained for compatibility */
     entry (dumpid);				/* Entry called from message coordr */

	use_r0m = "1"b;

common:
	if ^sc_stat_$test_mode then
	     error_entry = phcs_$ring_0_message;
	else error_entry = ioa_;

	abort = try_to_cleanup;			/* if get error while dumping, try to finish up */
	iocbp = null;
	call condition_ ("any_other", errx);		/* No recursion! */

	if static_dump_dir ^= "" then
	     dir = static_dump_dir;			/* something specific? */
	else dir = sc_stat_$sysdir;			/* no use default place */

	dir_dumpid = rtrim (dir) || " ";		/* set-up for
messages */
(nostringsize):
	dir_dumpid = dir_dumpid || dumpid;		/* directory name and dump identifier */
	call hcs_$quota_get (dir, quota, trp, tup, iqct, taccsw, used, ec);
	if ec ^= 0 then do;
	     if use_r0m then
		call error_entry ("as_dump_: Cannot obtain quota, dump aborted. " || dir_dumpid);
	     else call sys_log_$error_log (1, ec, "as_dump_", "Cannot obtain quota, dump aborted. ^a", dir_dumpid);
	     return;
	end;
	if quota ^= 0 then				/* Make sure there is room for the dump. */
	     if (quota - used) < ENOUGH then do;
		if use_r0m
		then call error_entry ("as_dump_: Out of room for dump " || dir_dumpid);
		else call sys_log_ (1, "as_dump_: Out of room for dump ^a", dir_dumpid);
		return;
	     end;
	call date_time_ (clock (), datstr);
	outname = "asdump.-." || substr (datstr, 1, 8) || "-" || substr (datstr, 11, 4);
	call iox_$find_iocb (STREAM, iocbp, ec);
	if ec ^= 0 then do;
attach_fail:   if use_r0m
	     then call error_entry ("as_dump_: Cannot attach I/O switch. No dump " || dir_dumpid);
	     else call sys_log_$error_log (1, ec, "as_dump_", "Cannot attach ^a to ^a. No dump ^a",
		     STREAM, outname, dir_dumpid);
	     return;
	end;
	call iox_$close (iocbp, (0));
	call iox_$detach_iocb (iocbp, (0));
	call iox_$attach_ptr (iocbp, "vfile_ " || pathname_ (dir, outname), null (), ec);
	if ec ^= 0 then go to attach_fail;
	call iox_$open (iocbp, Stream_output, ""b, ec);
	if ec ^= 0 then go to attach_fail;
	call ioa_$ioa_switch (iocbp, "^a  ^a^2/", datstr, dumpid);
	call cu_$stack_frame_ptr (sp);
	doing_stack_trace = "1"b;
	call trace_stack_$hregs (sp, 2, -1, (STREAM), 1);
	doing_stack_trace = ""b;
	call ioa_$ioa_switch (iocbp, "^/End of dump.^/");

try_to_cleanup:
	abort = just_return;			/* any errors from now on will return and not try to cleanup */
	if iocbp ^= null then do;
	     call iox_$close (iocbp, (0));
	     call iox_$detach_iocb (iocbp, (0));
	end;
	dpap = addr (dprint_arg_buf);			/* Set up to print segment. */
	dprint_arg.version = 1;
	dprint_arg.copies = 1;
	dprint_arg.delete = 0;
	dprint_arg.queue = 1;
	dprint_arg.pt_pch = 1;
	dprint_arg.notify = 0;
(nostringsize):
	dprint_arg.heading = " for asdump " || dumpid;
	dprint_arg.output_module = 1;
	dprint_arg.dest = "SysAdmin";

/**** Don't submit a dprint request for ASDUMP when we are debugging the
      answering service. */

	if ^sc_stat_$test_mode then
	     call dprint_ (dir, outname, dpap, ec);	/* Request IO daemon to print the dump. */

	if use_r0m
	then call error_entry ("as_dump_: Message coordinator dump created in segment " || outname);
	else call sys_log_ (1, "as_dump_: Answering service dump created in segment ^a", outname);
just_return:
	return;
%page;
set_as_dump_dir:
     entry options (variable);			/* establish residence of dumps */

dcl  reason char (64);

	reason = "Usage: as_$set_as_dump_dir <directory_path>";
	call cu_$arg_count (i, ec);
	if i ^= 1 | ec ^= 0 then do;
sdd_error:     call com_err_ (ec, "as_dump_$set_as_dump_dir", reason);
	     return;
	end;
	call cu_$arg_ptr (1, argp, argl, ec);		/* must have 1 arg */
	if ec ^= 0 then do;				/* how could this happen? */
	     call com_err_ (ec, "as_dump_$set_as_dump_dir", reason);
	     return;
	end;

	if arg = "" | arg = "-none" then do;
	     static_dump_dir = "";			/* indicate we should use working dir at time of fault */
	     return;
	end;

	reason = arg;
	call absolute_pathname_ (arg, dir, ec);		/* make sure it's absolute */
	if ec ^= 0 then go to sdd_error;		/* oh dear */
	reason = "getting quota";			/* make sure we can do this much later */
	call hcs_$quota_get (dir, quota, trp, tup, iqct, taccsw, used, ec);
	if ec ^= 0 then go to sdd_error;		/* but don't worry about actual quota */
	static_dump_dir = dir;			/* good enough to remember */
	return;
%page;
errx: proc (mcptr, cname, coptr, infoptr, cont);

dcl  (mcptr, coptr, infoptr) ptr, cname char (*), cont bit (1);

/* automatic */

dcl  reason char (64);
dcl  ucs_sp ptr;
dcl  try_again bit (1) aligned;

/* program */

	try_again = doing_stack_trace;		/* keep plugging to limit of recursion */
	if cname = "cleanup" then return;
	if cname = "storage" then go to foo;
	if cname = "command_error" then go to foo;
	if cname = "stack" then go to foo;
	if cname = "finish" then go to foo;
	if cname = "mme2" then go to foo;
	if cname = "cput" then go to foo;
	if cname = "alrm" then go to foo;
	if cname = "program_interrupt" then go to foo;
	if cname = "signal_io_" then go to foo;
	if cname = "quit" then do;
foo:	     cont = "1"b;
	     return;
	end;

	ucs_recursion = ucs_recursion + 1;
	if ucs_recursion <= 2 then do;
	     reason = "as_dump_: " || cname || " while dumping. Dump aborted.";
	     if ucs_recursion = 2 then do;		/* definitely the last time */
		use_r0m = "1"b;			/* don't use MC */
		try_again = "1"b;			/* remember to try */
	     end;
	     if use_r0m then			/* tell SOMEBODY */
		call error_entry (reason);
	     else call sys_log_ (1, reason);
	     if try_again then do;			/* once more? */
		call cu_$stack_frame_ptr (ucs_sp);
		call trace_stack_$hregs (ucs_sp, 2, -1, (STREAM), 1);
	     end;
	end;

	go to abort;

     end;

/* format: off */
%page; %include dprint_arg;
%page; %include iox_modes;
%page; %include sc_stat_;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   as_dump_: Answering service dump created in segment >sc1>asdump.-.MM/DD/YY-HHMM

   S:	as (severity1)

   T:	$run

   M:	Some program has encountered an unexpected fault and has
   called for a dump of the Answering Service.  This segment
   is automatically dprinted.

   A:	$ignore


   Message:
   as_dump_: Message coordinator dump created in segment >sc1>asdump.-.MM/DD/YY-HHMM

   S:	$info

   T:	$run

   M:	Some program has encountered an unexpected fault and has
   called for a dump of the message coordinator. This segment
   is automatically dprinted.

   A:	$ignore


   Message:
   as_dump_: CONDITION while dumping.  Dump aborted

   S:	as (severity1)

   T:	$run

   M:	During the attempt to perform an Answering Service dump, some
   unexpected fault occurred.  The dump is stopped and the system tries to continue.

   A:	Notify the system programming staff.


   Message:
   as_dump_: ERROR_MESSAGE.  Cannot attach as_dump_stream_ to FILENAME.  No dump asdump.MM/DD/YY-HHMM

   S:	as (severity1)

   T:	$run

   M:	The Answering Service dump program could not attach a file
   for the Answering Service dump.  The dump will abort, and the system
   will continue.

   A:	$inform


   Message:
   as_dump_: ERROR_MESSAGE. Cannot obtain quota of >sc1, dump aborted. DUMPID

   S:	as (severity2)

   T:	$run

   M:	An error occurred while dumping.
   No dump was taken.

   A:	$inform


   Message:
   as_dump_: Out of room for dump DUMPID

   S:	as (severity2)

   T:	$run

   M:	An error occurred while dumping.
   No dump was taken.

   A:	$inform


   Message:
   as_dump_: Cannot obtain quota, dump aborted. NAME

   S:	as (severity2)

   T:	$run

   M:	An error occurred while dumping.
   No dump was taken.

   A:	$inform


   Message:
   as_dump_: Cannot attach I/O switch. No dump NAME

   S:	as (severity2)

   T:	$run

   M:	An error occurred while dumping.
   No dump was taken.

   A:	$inform


   END MESSAGE DOCUMENTATION */

     end;




		    as_init_.pl1                    10/14/90  0953.6rew 10/14/90  0949.6      475794



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(86-05-15,Gilcrease), approve(86-05-16,MCR7370),
     audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082):
               Update UTE version to 3, for -truncate .absout SCP 6297.
  3) change(86-06-29,Swenson), approve(87-07-13,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Modified to zero anstbl.login_server_present upon AS initialization.
      B) Also added code to allow testing of answering service.
  4) change(87-03-10,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Also zeroed anstbl.(login_server_process_id
         login_server_event_channel) upon AS initialization.
      B) Removed initialization of ls_request_server_ from as_init_, since
         this facility is not B2 certified and is only needed at sites
         running DSA.
      C) Corrected coding errors and standard violations.
      D) Move initialization of ls_message_buffer back into as_init_.  It is
         needed for act_ctl_ and load_ctl_.
      E) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1
  5) change(87-05-06,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Don't call mc_quiesce_ when running test Answering Service.
  6) change(87-06-22,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correctly set as_data_$rs_ptrs.  The do group index wasn't properly
         used, causing reference through unset variable.
  7) change(87-06-28,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct error message printed for sub_error_ condition by ucs
         procedure.
  8) change(87-07-11,GDixon), approve(87-07-11,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Set as_data_$rtdtp to null after the RTDT is terminated by as_init_.
  9) change(87-07-27,GDixon), approve(87-07-27,MCR7741),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Removed call to network_accounting_gate_$test.  This is now done in
         ls_request_server_$init.
      B) Added descriptions for undoc'd operator messages.
      C) Convert to sys_log_$general for many calls.
 10) change(87-08-28,GDixon), approve(87-08-28,PBF7741),
     audit(87-08-28,Martinson), install(87-09-01,MR12.1-1095):
      A) Correct calls to Abort internal proc to ensure that they always pass
         a ioa_ control string.  Otherwise, sys_log_$general reports an
         error.
      B) Change $check_shut_ok to check for as_data_$ansp being null.  If so,
         then set return arg to indicate no users are logged in.
 11) change(87-09-24,GDixon), approve(88-01-06,MCR7786),
     audit(88-01-08,Parisek), install(88-01-12,MR12.2-1012):
      A) Change calls to Abort internal proc to pass a code of -1 rather than
         0.  Abort calls sys_log_$general which ignores the message in the
         call when the code is 0.  It special-cases code values of -1 by
         printing the ioa_ control string but excluding expansion of the
         error table code value. (as 562)
      B) Call condition_interpreter_ to further describe unexpected conditions
         occurring during as initialization. (as 394, phx18406)
 12) change(90-10-03,WAAnderson), approve(90-10-03,MCR8213),
     audit(90-10-10,Vu), install(90-10-14,MR12.4-1040):
     Removed extraneous '^a:' from log message.
                                                   END HISTORY COMMENTS */


/* format: style4 */
as_init_:
     proc (a_code);

/* Answering Service initization procedure

   Originally coded by J. F. Ossanna Jan 1969
   Recoded by Michael J. Spier and Robert C. Daley February 1969
   Revised by Michael D. Schroeder,  June 1969
   Recoded in PL/1 for new System/User Control by Michael J. Spier,  January 1970
   revised nov 70 THVV
   modified for new SAT format by Janice B. Phillipps, March 1972
   revised March 73 THVV
   Modified 750309 by PG to add request dispatcher
   Modified 750415 by PG to initialize initial_modes_table
   Modified July 1975 by: WSS, TAC, and LJS, for RCP, Priority Scheduler, and syserr logging, respectively.
   Modified Aug 75 by THVV for Channel Definition Table
   Modified April 1976 by T. Casey to be sure to print error messages if initialization fails
   Modified May 1976 by T. Casey to save and restore shift information in whotab header,
   .                and by P. Green to change initial modes for network lines.
   Modified 760618 by Roy P. Planalp to attach FTP channels
   Modified August 1976 by T. Casey to initialize for loading FNPs.
   Modified November 1976 by T. Casey to fix initialization of stopped FNP.
   Modified December, 1976, by D. M. Wells to validate ARPANET host number in
   installation_parms.
   Modified June, 1977, by Robert S. Coren to remove references to initial_modes_table.
   Modified August 1977 by T. Casey to call pdir_volume_manager_$init.
   .		and to complete channel deletions requested by CDT installations during last bootload.
   Modified 03/20/78 by C. D. Tavares for new rcp handling (RTDT).
   Modified May 1978 by T. Casey to add an argument to the load_ctl_$set_maxunits call.
   Modified Fall 1978 by Larry Johnson for ring-0 demultiplexing.
   Modified November 1978 by T. Casey for MR7.0 absentee control parameters and other new installation_parms.
   Modified April 1979 by T. Casey for Mr7.0a to put back feature to not do automatic abs start in a special session.
   Modified August 1979 by C. Hornig to only listen to non-MCS channels during initialization and for new PNT.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified March 1980 by Tom Casey to implement metering of answering service resource usage.
   Modified June 1981 by E. N. Kittlitz for UNCA rate-structures
   Modified June 1981 by T. Casey for MR9.0 to set event wait channel priority highest.
   Modified August 1981 by E. N. Kittlitz for ucs recursion counter.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981, E. N. Kittlitz.  convert to whotab version 1.
   Modified December 1981, Benson I. Margulies. CDT tree initialization.
   Modified February 1982, E. N. Kittlitz  to fix ucs recursion counter.
   Modified April 1982, E. N. Kittlitz. beginnings of new AS initialization strategy.
   Modified October 1982, E. N. Kittlitz.  rename as_request_ to as_request_server_, add mc_quiesce_.
   Modified January 1982, E. N. Kittlitz.  turn_on_mc_ before doing anything else.
   Modified 83-11-21 BIM. turn quota checking on, having changed pds to start out with quota checking off.
   Modified 84-04-02 BIM. Remove support for cdte.dim. All channels are MCS.
   Modified 1984-09-13 BIM. Initialize anstbl.max_users, the answering
   service's idea of the number of APTE's, from the
   TCD card. This insures consistency with the hardcore.
   Modified:
   10/02/84 by R. Michael Tague: Changed the as_data_$acsdir from rcp to
   admin_acs.
   Modified 84-11-04 by E. A. Ranzenbach for whotab.session...
   Modified 1984-12, BIM: ssu_ system control and related changed.
   Modified 1985-01-15 by E. Swenson for anstbl.session_uid_counter.
   Modified 1985-02-18, BIM: call as_user_message_$system_init.
   Modified 1985-04-19, E. Swenson to correct any_other handler.
*/

/* Parameters */

dcl  a_code fixed bin (35) parameter;
dcl  a_n_users fixed bin (35) parameter;

/* External Static */

dcl  active_all_rings_data$system_id char (8) aligned ext;
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$no_r_permission fixed bin (35) ext static;
dcl  error_table_$no_w_permission fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$unexpected_condition fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  sys_info$max_seg_size fixed bin (35) ext static;

/* Entries */

dcl  absentee_user_manager_$abs_as_init entry;
dcl  absentee_user_manager_$term_aum entry;
dcl  act_ctl_$act_ctl_close entry;
dcl  act_ctl_$init entry;
dcl  admin_$down1 entry (fixed bin (71), char (*) aligned, fixed bin (71));
dcl  as_dump_$dont_use_mc entry (char (*));
dcl  as_meter_$asmt_init entry;
dcl  as_meter_$enter entry (fixed bin);
dcl  as_meter_$exit entry (fixed bin);
dcl  as_request_server_$init entry;
dcl  asu_$init entry;
dcl  as_user_message_$priv_system_init entry (fixed bin (35));
dcl  cdt_mgr_$thread entry (ptr, fixed bin (35));
dcl  condition_ entry (char (*), entry);
dcl  config_$find entry (character (4) aligned, pointer);
dcl  cu_$level_set entry (fixed bin (6));
dcl  daemon_user_manager_$init entry;
dcl  device_acct_$init entry;
dcl  dialup_$init entry;
dcl  get_group_id_ entry () returns (char (32));
dcl  get_group_id_$tag_star entry () returns (char (32));
dcl  get_process_id_ entry () returns (bit (36));
dcl  get_ring_ entry () returns (fixed bin (3));
dcl  get_system_free_area_ entry() returns(ptr);
dcl  hash_$search entry (ptr, char (*), bit (36) aligned, fixed bin (35));
dcl  hc_initlzr_auxl_init_$init entry;
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35));
dcl  hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
dcl  hcs_$terminate_noname ext entry (pointer, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hphcs_$restore_quota entry;
dcl  ipc_$set_wait_prior entry (fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  lg_ctl_$init entry (bit (1) aligned);
dcl  load_ctl_$init entry;
dcl  load_ctl_$set_maxunits entry (fixed bin);
dcl  ls_request_server_$shutdown entry (fixed bin (35));
dcl  mail_table_priv_$test entry (char (*));
dcl  mc_quiesce_ entry;
dcl  multiplexer_mgr_$init entry (pointer, fixed bin (35));
dcl  multiplexer_mgr_$shut entry;
dcl  multiplexer_mgr_$system_go entry;
dcl  multiplexer_mgr_$system_init entry (fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  pdir_volume_manager_$init entry;
dcl  phcs_$ring_0_message entry (char (*));
dcl  pnt_manager_$test entry (char (*));
dcl  rcp_sys_$initialize ext entry (1 aligned like rcp_init_flags, fixed bin (35));
dcl  reassign_work_classes_ entry (fixed bin (35));
dcl  sys_log_ entry options (variable);
dcl  syserr_log_man_$as_copy_init entry (char (*), fixed bin (9));
dcl  syserr_log_man_$as_copy_log entry;
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  turn_on_mc_ entry;
dcl  up_sat_$make_sat_hash entry (ptr, fixed bin, ptr, char (*), fixed bin (35));
dcl  up_sysctl_$init entry;

/* builtins */

dcl  (addr, bin, bit, clock, divide, fixed, hbound, length, null, rel, rtrim, size, substr) builtin;

/* Internal Static */

dcl  (next_sd, next_sd_until) fixed bin (71) int static;
dcl  next_sd_msg char (124) aligned int static;

/* Constant */

dcl  FALSE bit (1) aligned initial ("0"b) internal static options (constant);
dcl  ME char (8) int static init ("as_init_") options (constant);
dcl  MINS_30 fixed bin (71) int static init (1800000000) options (constant);
dcl  NL char (1) aligned int static init ("
") options (constant);
dcl  TRUE bit (1) aligned initial ("1"b) internal static options (constant);

/* Automatic */

dcl  abort_label label automatic;
dcl  answer char (100);
dcl  autp ptr automatic;
dcl  cdt_scan_try_count fixed bin;
dcl  check fixed bin;
dcl  code fixed bin (35);
dcl  debug_flag bit (1) aligned automatic;
dcl  dutp ptr automatic;
dcl  error_message_entry entry variable options (variable);
dcl  i fixed bin;
dcl  ip ptr automatic;
dcl  last_sc fixed bin (71);
dcl  metering_enabled bit (1) aligned automatic;
dcl  n_acl fixed bin;
dcl  next_sc fixed bin (71);
dcl  normal_flag bit (1) aligned;
dcl  rbkt (3) fixed bin (3);
dcl  rs_name char (32) automatic;
dcl  rs_number fixed bin automatic;
dcl  sat_htp ptr automatic;
dcl  satp ptr automatic;
dcl  shift fixed bin;				/* to save shift info while truncating whotab */
dcl  system_area_ptr        ptr automatic;
dcl  system_control_dir char (168) automatic;
dcl  ucs_recursion fixed bin init (0);			/* level of signal recursion */
dcl  x fixed bin;
dcl  whoptr ptr automatic;

dcl  1 acla (5) aligned,				/* ACL structure */
       2 userid char (32),
       2 mode bit (36),
       2 rpad bit (36) init ((5) (36)"0"b),
       2 retcd fixed bin (35);

dcl  1 our_acl aligned like general_extended_acl_entry automatic;

/* Based */

dcl  system_area	        area based (system_area_ptr);

/* INCLUDE FILES are at the end, after all the code, but before the message documentation */

as_init:
     entry (a_code);

	normal_flag = "0"b;				/* Special session */
	go to initialize;

startup:
     entry (a_code);

	normal_flag = "1"b;				/* not special session */

initialize:

	metering_enabled = FALSE;
	code = 0;
	abort_label = INIT_RETURN;

	if sc_stat_$Multics then			/* reject re-initialization */
	     call Abort (error_table_$action_not_performed,
		"Multics already initialized.");

	if sc_stat_$test_mode then do;		/* are we debugging? */
	     as_data_$debug_flag = TRUE;
	     debug_flag = TRUE;
	end;
	else do;					/* not debugging */
	     as_data_$debug_flag = FALSE;
	     debug_flag = FALSE;
	end;

	system_control_dir = sc_stat_$sysdir;		/* copy system directory name into internal static */
	as_data_$sysdir = system_control_dir;
	as_data_$pdtdir = rtrim (system_control_dir) || ">pdt";
	as_data_$acsdir = rtrim (system_control_dir) || ">admin_acs";
	as_data_$rcpdir = rtrim (system_control_dir) || ">rcp";

	if ^debug_flag then
	     call condition_ ("any_other", ucs);	/* Set up ugh. */

	if ^debug_flag then
	     call hphcs_$restore_quota;		/* allow record_quota_overflow */
	call as_meter_$asmt_init;
	call as_meter_$enter (ASINIT_METER);
	metering_enabled = TRUE;

/* get the SAT. We need it now to set up the acl structure */

	call Initiate_Segment ("sat", satp);
	as_data_$satp = satp;

	if sat.version ^= SAT_version then		/* SAT must be correct flavor. */
	     call Abort (error_table_$unimplemented_version,
		"SAT version inconsistent with declarations used in this program.");


	rbkt (1) = as_data_$as_ring;			/* Set up ring brackets. */
	rbkt (2), rbkt (3) = as_data_$max_user_ring;
	acla.userid (1) = get_group_id_ ();		/* Set up useful ACL. */
	acla.userid (2) = "*.SysDaemon.*";		/* ... */
	n_acl = 3;				/* Continue with 3rd acla entry. */
	do i = 1 to 2 while (sat.system_admin (i) ^= ""); /* Generate ACL entries for the good guys */
	     acla.userid (n_acl) = rtrim (sat.system_admin (i)) || ".*"; /* Put administrators on ACL. */
	     n_acl = n_acl + 1;			/* ... */
	end;
	acla.userid (n_acl) = "*.*.*";		/* This ACL provides for everybody. */
	do i = 1 to n_acl;				/* More setup. */
	     acla.mode (i) = RW_ACCESS;		/* RW for all entries. */
	end;
	acla.mode (2) = R_ACCESS;			/* Daemons not to mess up */
	acla.mode (n_acl) = N_ACCESS;			/* Average user gets no access to system tables. */

	call ipc_$set_wait_prior (code);		/* Input on operator console has highest priority */
						/* See as_wakeup_priorities.incl.pl1 for more information */
	if code ^= 0 then
	     call Log_Error (code,
		"Could not set priority for IPC wait channels.");

/* set up the template pit */

	call hcs_$make_seg ("", "pit_temp_", "", 01011b, as_data_$pit_ptr, code); /* create pit template segment */
	if as_data_$pit_ptr = null then		/* what! our own process directory? */
	     call Abort (code, "Cannot create pit_temp_.");

/* get the SAT paraphernalia */

	call Create_Segment ("sat.ht", sat_htp);	/* by hook or by crook */

	if sat_htp -> htable.id ^= "ht01" & sat_htp -> htable.id ^= "ht02" then go to make_sat_hash; /* reasonable? */
	call hash_$search (sat_htp, "SysDaemon", (""b), code); /* give it a try */
	if code ^= 0 then do;
make_sat_hash: call Log_Error (-1, "Rebuilding SAT hash table.");
	     call up_sat_$make_sat_hash (satp, sat.n_projects, sat_htp, answer, code);
	     if code ^= 0 then
		call Abort (code, "Cannot create ^a>sat.ht. ^a.",
		     system_control_dir, answer);
	end;
	as_data_$sat_htp = sat_htp;

/* Setup the various user tables */

	call Create_Segment ("answer_table", ansp);
	as_data_$ansp = ansp;
	call Create_Segment ("absentee_user_table", autp);
	as_data_$autp = autp;
	call Create_Segment ("daemon_user_table", dutp);
	as_data_$dutp = dutp;

/* Get installation parameters and rate structures */

	call Initiate_Segment ("installation_parms", ip);
	as_data_$rs_ptrs (0) = ip;

	if installation_parms.version ^= installation_parms_version_2 then
	     call Abort (error_table_$unimplemented_version,
		"installation_parms version ^d",
		installation_parms.version);

	if installation_parms.nrates < 0 |
	     installation_parms.nrates > hbound (as_data_$rs_ptrs, 1) then
	     call Abort (-1,
		"installation_parms damaged. ^d rate structures defined; from ^d to ^d are allowed.",
		installation_parms.nrates, 0, hbound(as_data_$rs_ptrs,1));

	do rs_number = 1 to installation_parms.nrates;	/* other rates */
	     call ioa_$rsnnl ("rate_structure_^d", rs_name, (0), rs_number);
	     call Initiate_Segment (rs_name, as_data_$rs_ptrs (rs_number));
	end;

	if installation_parms.chn_wakeup_error_loop_count <= 0 then installation_parms.chn_wakeup_error_loop_count = 10;
	if installation_parms.chn_wakeup_error_loop_seconds <= 0 then
	     installation_parms.chn_wakeup_error_loop_seconds = 3;

/* The resource stuff */

	call Initiate_Segment ("rtdt", rtdtp);
	as_data_$rtdtp = rtdtp;

	RTDT_area_len = 0;				/* avoid PL/1 warning */
	if rtdt.installed_under_resource_mgt then
	     if installation_parms.rcp_init_flags.resource_mgmt_enabled = ""b then
		call Abort (-1, "Resource management is disabled; ^a>rtdt needs it enabled.",
		     system_control_dir);

	as_data_$rtdtp = null;
	call hcs_$terminate_noname (rtdtp, 0);

/* First shot at the multiplexers */

	call multiplexer_mgr_$init (cdtp, code);	/* Get cdt ptr */
	if code ^= 0 then
	     call Abort (code, "Calling multiplexer_mgr_$init.");
	as_data_$cdtp = cdtp;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Initialize the who table.  This is a public listing of logged-in users    */
/* Cannot use Create_Segment for this, since whotab must have nonnull	       */
/* reference name.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call hcs_$make_seg (system_control_dir, "whotab", "whotab_", 1010b, whoptr, code);
	if whoptr = null then
	     call Abort (code, "Could not create ^a>whotab",
		system_control_dir);

	our_acl.access_name = get_group_id_$tag_star ();
	our_acl.mode = RW_ACCESS;
	our_acl.extended_mode = ""b;
	our_acl.status_code = 0;

	call hcs_$add_acl_entries (system_control_dir, "whotab", addr (our_acl), 1, code);
	if code ^= 0 then
	     call Abort (code, "Could not set RW access on ^a>whotab.",
		system_control_dir);

	as_data_$whoptr = whoptr;
	next_sd = whotab.nextsd;			/* Was previous shutdown? */
	next_sd_msg = whotab.why;			/* .. if so we save it */
	next_sd_until = whotab.until;
	shift = whotab.shift;			/* save shift info */
	next_sc = whotab.next_shift_change_time;
	last_sc = whotab.last_shift_change_time;
	call hcs_$truncate_seg (whoptr, 0, code);	/* Clear out all old junk. */

/* truncating whotab is too drastic. change it some time.
   NOTE: for MR10, a kludge was devised to allow expansion of the whotab
   header.  The header was 64 words long, user entries were 32 words.
   A number of the early user entries were appropriated, with the understanding
   the every 32 words from 100o up, there would be a word of 0s, corresponding
   to the user entry being empty.  This allows existing programs to run
   without recompilation, provided that they honour the entry 'active' flag.
   If truncation is eliminated, it must be ensured that this contract is kept.
   Throughout the Answering Service, the value whotab.as_laste is used to
   indicate the last used whotab index.  User programs use whotab.laste,
   which is the sum of whotab.as_laste and whotab.laste_adjust.
*/

	whotab.version = WHOTAB_VERSION_1;
	whotab.header_size = fixed (rel (addr (whotab.e (1))));
	whotab.entry_size = fixed (rel (addr (whotab.e (2)))) - fixed (rel (addr (whotab.e (1))));
	whotab.laste_adjust, whotab.laste =
	     divide (whotab.header_size - fixed (rel (addr (whotab.header_extension_mbz1))), whotab.entry_size, 17, 0);
	whotab.shift = shift;			/* put shift info back */
	whotab.next_shift_change_time = next_sc;
	whotab.last_shift_change_time = last_sc;
	whotab.n_rate_structures = installation_parms.nrates; /* number of R.S. at AS init */
	acla.mode (n_acl) = R_ACCESS;			/* whotab is public */
						/* Create_Segment resets this back to N_ACCESS */

	call hcs_$replace_acl (system_control_dir, "whotab", addr (acla), n_acl, "1"b, code);
	call hcs_$set_ring_brackets (system_control_dir, "whotab", rbkt, code);

/* now initialize various control variables */

	anstbl.header_version = ANSTBL_version_4;	/* setup version number of dcl */
	anstbl.entry_version = UTE_version_4;
	anstbl.user_table_type = PT_INTERACTIVE;
	anstbl.header_length = fixed (rel (addr (anstbl.entry (1))));
	anstbl.max_size = divide (sys_info$max_seg_size - anstbl.header_length, size (ute), 17, 0);
	anstbl.number_free,
	     anstbl.first_free,
	     anstbl.current_size,			/* Clear number of busy entries. */
	     anstbl.lock_count,			/* Clear update interlock. */
	     anstbl.nlin,				/* Reset number of lines attached. */
	     anstbl.n_units,			/* Clear load on system. */
	     anstbl.n_users = 0;			/* Clear number of users. */

	anstbl.update_pending = "1"b;			/* make sure to look in update directory */
/**** The following substring is necessary because anstbl.sysdir is only
      declared char (64). */
	anstbl.sysdir = substr (system_control_dir, 1, 64);
	anstbl.special_message = NL;			/* Nothing special in dialup buffer. */
	anstbl.message_lng = 0;			/* ... */
	anstbl.message_update_time = clock ();

	tcd_cardp = null ();
	call config_$find (TCD_CARD_WORD, tcd_cardp);
	if tcd_cardp = null ()
	then do;
	     call Log_Error (-1,
		"No ""tcd"" card in the config deck.  Assuming APT size of 1000.");
	     anstbl.max_users = 1000;
	end;
	else anstbl.max_users = tcd_card.no_apt;	/* avoid errors from hardcore when we reach APT limit */

	anstbl.max_units = sat.max_units;		/* ... */
	anstbl.n_sessions = anstbl.n_sessions + 1;	/* Number of boots. */
	anstbl.as_tty = sc_stat_$master_channel;	/* Copy in channel ID of initializer. */
	as_data_$as_procid, anstbl.as_procid = get_process_id_ (); /* Set up system process ID. */
	anstbl.processid_index = bin (substr (bit (bin (clock (), 52), 52), 9, 18), 18);
	anstbl.session_uid_counter = 0;		/* login attempts will increment */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* The following flag, zeroed at answering service initialization time, is   */
/* used by dial_ctl_ to determine whether to call uc_cleanup_network_dials_  */
/* or not.  The flag is turned on by ls_rq_server_wakeup_ when a login       */
/* server request comes in -- indicating that there is indeed at least one   */
/* login server and it is potentially necessary to clean up MNA dialed       */
/* connections.  The process_id and event_channel are cleared here since     */
/* they are used by ls_request_server_$init to determine if the	       */
/* ls_request_server_ mechanism is already on.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	anstbl.login_server_present = FALSE;
	anstbl.ls_request_server_process_id = ""b;
	anstbl.ls_request_server_event_channel = 0;

	if normal_flag then				/* Normal startup? */
	     anstbl.auto_maxu = 1;			/* Yes. Turn on config-dependent load setting. */
	else do;
	     anstbl.auto_maxu = 0;			/* Otherwise leave it off, since this is a special session */
	     call absentee_user_manager_$term_aum;	/* tell absentee not to start automatically */
	end;

	call cu_$level_set ((get_ring_ ()));		/* force validation level to current ring */

	whotab.sysid = active_all_rings_data$system_id;	/* Get supervisor version from system tape. */
	whotab.timeup = clock ();			/* Set bootload time. */
	whotab.mxunits = anstbl.max_units;		/* Publish maxunits. */
	whotab.mxusers = anstbl.max_users;		/* Also max users. */

/* Now let other Answering Service procedures initialize themselves */

	call turn_on_mc_;				/* turn on the message coordinator */
						/* NOTE: we must not use the CDT */

	call up_sysctl_$init;			/* Allow table updates. */

	if ^debug_flag then do;
	     call multiplexer_mgr_$system_init (code);	/* Initialize CDT and get FNPs started loading */
	     if code ^= 0 then
		call Abort (code, "Calling multiplexer_mgr_$system_init.");
	end;

	call dialup_$init;				/* Turn on interactive user manager. */

	call as_request_server_$init;

	call device_acct_$init;			/* Set up device accounting table. */

	if ^debug_flag then do;
	     call as_user_message_$priv_system_init (code); /* Start up message transmission system. */
	     if code ^= 0 then
		call Abort (code, "Calling as_user_message_$priv_system_init.");

	     call rcp_sys_$initialize (installation_parms.rcp_init_flags, code);
	     if code ^= 0 then
		call Abort (code, "Calling rcp_sys_$initialize.");

	     call hc_initlzr_auxl_init_$init;		/* MUST COME AFTER CALL TO rcp_sys_$initialize */
	end;

	call lg_ctl_$init (normal_flag);

	call load_ctl_$init;

	call asu_$init;

	call daemon_user_manager_$init;		/* must do before act_ctl_$init and after lg_ctl_$init */

	call absentee_user_manager_$abs_as_init;	/* clear autbl before act_ctl_$init and reassign_work_classes_ */

	call act_ctl_$init;

/**** This is, logically, a part of load_ctl_init, but it must be done after
      act_ctl_$init is called, which defines the shift. */

	call reassign_work_classes_ (code);		/* this is, logically, a part of load_ctl_init */
	if code ^= 0 then
	     call Abort (code, "Error while defining initial work classes.");

	if ^debug_flag then do;
	     call pdir_volume_manager_$init;

/**** Initialize copying of syserr log out of ring 0 */
	     call syserr_log_man_$as_copy_init ("perm_syserr_log", installation_parms.syserr_log_copy_threshold);
	end;

/**** If we are debugging the AS, use a special version of the PNT and
      MAIL_TABLE. */
	if debug_flag then do;
	     call pnt_manager_$test (system_control_dir);
	     call mail_table_priv_$test (system_control_dir);
	end;

	call Initialize_Login_Server_Message_Buffer ();

	call Log_Error (-1, "Multics ^a; Answering Service ^a",
	     whotab.sysid, as_data_$version);		/* Not really an */
						/* error.	       */

INIT_RETURN:
	if metering_enabled then
	     call as_meter_$exit (ASINIT_METER);
	a_code = 0;
	return;
%page;
/* ============================================================= */

go:
     entry (a_code);

          ansp = as_data_$ansp;
	code = 0;
	debug_flag = as_data_$debug_flag;
	cdtp = as_data_$cdtp;			/* get automatic storage back */
	metering_enabled = FALSE;
	abort_label = GO_RETURN;

	if sc_stat_$Go then				/* called already */
	     call Abort (error_table_$action_not_performed,
		"Cannot type go twice.");

	if ^sc_stat_$Multics then			/* multics not called yet */
	     call Abort (error_table_$action_not_performed,
		"Type multics first.");

	if ^debug_flag then
	     call condition_ ("any_other", ucs);	/* in case die during init */
	call as_meter_$enter (ASINIT_METER);

	if ^debug_flag then do;
	     call Check_CDT ();

	     call multiplexer_mgr_$system_go;		/* in case any FNPs came up before we said "go" */
	end;

	call load_ctl_$set_maxunits (anstbl.shift);	/* just returns if auto_maxu is zero */

/**** Should we set up an auto shudtown? */
	if next_sd > clock () + MINS_30 then do;	/* Should we set up an auto shudtown? */
	     call admin_$down1 (next_sd, next_sd_msg, next_sd_until);
	end;

	if anstbl.update_pending then do;		/* kick-off any installs */
	     whoptr = as_data_$whoptr;
	     call hcs_$wakeup (whotab.installation_request_pid, whotab.installation_request_channel, 0, (0));
	end;

GO_RETURN:
	if metering_enabled then
	     call as_meter_$exit (ASINIT_METER);
	a_code = 0;
	return;

%page;
/* ====================================================== */

check_shut_ok:
     entry (a_n_users);

	ansp = as_data_$ansp;
	if ansp = null then
	   a_n_users = 0;
	else
	   a_n_users = anstbl.n_users;
	return;
%page;
/* ====================================================== */

shutdown:
     entry ();					/* Small entry for shutting system down. */

	ansp = as_data_$ansp;
	whoptr = as_data_$whoptr;
	ip = as_data_$rs_ptrs (0);

	anstbl.session, whotab.session = "shutdown";	/* No more logins */
	whotab.nextsd = 0;				/* Prevent restoring */
	if installation_parms.syserr_log_copy_threshold ^= -1 then
						/* If automatic copying enabled... */
	     call syserr_log_man_$as_copy_log ();	/* ...then copy the last few messages out of ring 0 */

	call act_ctl_$act_ctl_close;			/* All engines stop */
	if ^as_data_$debug_flag then
	     call mc_quiesce_;			/* wait for messages to finish */
	call timer_manager_$sleep (2, "11"b);		/* and a bit more for good luck */

	if ^as_data_$debug_flag then
	     call multiplexer_mgr_$shut;		/* don't listen to them anymore */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Although we didn't start up the ls_request_server_ during initialization, */
/* we will force it to stop running during AS shutdown.  It gets started by  */
/* the ls_request_server command.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call ls_request_server_$shutdown (code);
	if code ^= 0 then
	     call Log_Error (code,
	     "Shutting down the login server request mechanism.");

	return;
%page;
Create_Segment:
     procedure (P_table_name, P_table_ptr);

dcl  P_table_name char (*) parameter;
dcl  P_table_ptr ptr parameter;

dcl  local_code fixed bin (35) automatic;

TRY_AGAIN:
	call initiate_file_ (system_control_dir, P_table_name, RW_ACCESS,
	     P_table_ptr, (0), local_code);
	if local_code = 0 then
	     return;
	else if local_code = error_table_$noentry then do;
	     call Log_Error (-1, "^a>^a missing.  Creating new one.",
		system_control_dir, P_table_name);
	     call hcs_$make_seg (system_control_dir, P_table_name, "",
		01010b, P_table_ptr, local_code);
	     if P_table_ptr = null () then
		call Abort (local_code, "Could not create ^a>^a.",
		     system_control_dir, P_table_name);
	     return;
	end;
	else if local_code ^= error_table_$no_r_permission &
	     local_code ^= error_table_$no_w_permission then
	     call Abort (local_code, "Could not initiate ^a>^a.",
		system_control_dir, P_table_name);
	else do;					/* no access */
	     call Log_Error (local_code, "^a>^a.  Forcing access.",
		system_control_dir, P_table_name);
	     acla.mode (n_acl) = N_ACCESS;		/* random user get null access */
	     call hcs_$replace_acl (system_control_dir, P_table_name,
		addr (acla), n_acl, "1"b, local_code);
	     if local_code ^= 0 then
		call Abort (local_code, "Could not force access on ^a>^a.",
		     system_control_dir, P_table_name);
	     else
		goto TRY_AGAIN;
	end;
	return;
     end Create_Segment;
%page;
ucs:
     proc (mcptr, cname, coptr, infoptr, contin);

dcl  mcptr ptr parameter;
dcl  cname char (*) parameter;
dcl  coptr ptr parameter;
dcl  infoptr ptr parameter;
dcl  contin bit (1) parameter;

dcl  cond_info char(cond_info_lng) based (cond_info_ptr);
dcl  cond_info_lng fixed bin;
dcl  cond_info_ptr ptr;

dcl  non_local_exit bit (1);

dcl  as_check_condition_ entry (char (*), bit (1), bit (1));
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char(*), ptr, ptr);

dcl  cleanup condition;

dcl  LONG_MODE fixed bin init(3) int static options(constant);

	call as_check_condition_ (cname, contin, non_local_exit);
	if contin | non_local_exit then
	     return;

	code = error_table_$action_not_performed;

	ucs_recursion = ucs_recursion + 1;		/* recursion ok up to here */
	if ucs_recursion <= 1 then do;
	     if cname = "sub_error_" then do;
		sub_error_info_ptr = infoptr;
		if sub_error_info.default_restart & sub_error_info.quiet_restart then return;
		code = sub_error_info.status_code;
		call Log_Error (code,
		     "^[Initialization of ^a failed.^;^a signalled sub_error_; initialization continues.^]^[ ^a^]",
		     ^sub_error_info.default_restart, sub_error_info.name,
		     (length (sub_error_info.info_string) > 0), sub_error_info.info_string);
		if sub_error_info.default_restart then return;
	     end;
	     else do;
 		call Log_Error (-1,

		     "^a: Condition ^a signalled during startup.  Taking AS dump.", ME, cname);
	          system_area_ptr = get_system_free_area_();
		cond_info_ptr = null;
		on cleanup begin;
		     if cond_info_ptr ^= null then
			free cond_info in (system_area);
		end;
		call condition_interpreter_ (addr(system_area),
		     cond_info_ptr, cond_info_lng, LONG_MODE,
		     mcptr, cname, coptr, infoptr);
		if cond_info_ptr ^= null then do;
		     call Log_Error (-1, "^a", cond_info);
		     free cond_info in (system_area);
		end;
		call as_dump_$dont_use_mc ("as_init_: " || cname);
	     end;
	     call Abort (code, "");
	end;
	else do;
	     if ^debug_flag then
		error_message_entry = phcs_$ring_0_message;
	     else error_message_entry = ioa_;

	     call error_message_entry ("as_init_: Condition was signalled while processing another condition.  " || cname);
	     call error_message_entry ("as_init_: Answering Service initialization failed.");
	     call Abort (error_table_$unexpected_condition, "");
	end;

     end ucs;
%page;
Initialize_Login_Server_Message_Buffer:
     procedure ();

dcl  ls_message_buffer_max_lth fixed bin automatic;
dcl  ls_message_buffer_ptr  ptr automatic;

dcl  ls_message_buffer      char (ls_message_buffer_max_lth)
		        based (ls_message_buffer_ptr);

/**** Start out with a buffer 512 character-long buffer. */

          system_area_ptr = get_system_free_area_();
	ls_message_buffer_max_lth,
	     as_data_$ls_message_buffer_max_lth = 512;
	allocate ls_message_buffer in (system_area) set (ls_message_buffer_ptr);
	ls_message_buffer = "";			/* clear out buffer */
	as_data_$ls_message_buffer_cur_lth = 0;
	as_data_$ls_message_buffer_ptr = ls_message_buffer_ptr;
	return;
     end Initialize_Login_Server_Message_Buffer;
%page;
Initiate_Segment:
     procedure (P_table_name, P_table_ptr);

dcl  P_table_name char (*) parameter;
dcl  P_table_ptr ptr parameter;

	call initiate_file_ (system_control_dir, P_table_name, RW_ACCESS,
	     P_table_ptr, (0), code);
	if code ^= 0 then
	     call Abort (code, "Could not initiate ^a.",
		pathname_ (system_control_dir, P_table_name));
	return;
     end Initiate_Segment;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general, report that Answering	       */
/*	 Service initialization failed, then return to caller of as_init_  */
/*	 with nonzero error code.				       */
/*							       */
/* Syntax:  call Abort (code, ioa_ctl, args);			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


Abort:
     procedure options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_code_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.severity = SL_LOG;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0 then do;
	     call sys_log_ (SL_LOG_BEEP,
	        "^a: Answering Service initialization failed.", ME);
	     go to abort_label;
	end;

     end Abort;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error:  Report errors via sys_log_$general, continue initialization.  */
/*							       */
/* Syntax:  call Log_Error (code, ioa_ctl, args);			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


Log_Error:
     procedure options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_code_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.severity = SL_LOG;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	return;

     end Log_Error;
%page;
Check_CDT:
     procedure ();

/* Scan the CDT and find all non-MCS channels which should be attached to
   the Answering Service.  All such channels will be top level multiplexers
   other than FNP's */

	cdt_scan_try_count = 0;

RETRY_CDT_SCAN:
	check = 0;
	do x = cdt.threads.daughter repeat (cdt.cdt_entry (x).next_sister)
	     while (x ^= 0);
	     cdtep = addr (cdt.cdt_entry (x));
	     check = check + 1;
	     if check > cdt.threads.daughter_count | check > cdt.n_cdtes
		| cdte.threads.mother ^= 0
	     then goto CDT_DAMAGE;
	end;
	return;
%page;
CDT_DAMAGE:
	begin;					/* Inconsistency found while chasing cdt threads */

declare  sub_error_ condition;
declare  find_condition_info_ entry (ptr, ptr, fixed bin (35));
declare  1 auto_condition_info aligned like condition_info;

	     if cdt_scan_try_count > 0
	     then do;
		call multiplexer_mgr_$shut ();
		call Abort (error_table_$action_not_performed,
		     "Repeated CDT threading inconsistencies.");
	     end;

	     call Log_Error (-1,
		"CDT threading inconsistency found. 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 Log_Error (sub_error_info.status_code,
		     "cdt_mgr_$thread: ^a", sub_error_info.info_string);
		if ^sub_error_info.default_restart
		then do;
		     call multiplexer_mgr_$shut;
		     call Abort (sub_error_info.status_code, "");
		end;
	     end;

	     call cdt_mgr_$thread (cdtp, (0));
	     call Log_Error (-1, "CDT rethreading complete.");
	     cdt_scan_try_count = 1;
	     goto RETRY_CDT_SCAN;
	end;
     end Check_CDT;

/* INCLUDE FILES, IN ALPHABETIC ORDER */

/* format: off */
%page; %include access_mode_values;
%page; %include acl_structures;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_meter_numbers;
%page; %include author_dcl;
%page; %include cdt;
%page; %include condition_info;
%include condition_info_header; 
%page; %include config_tcd_card;
%page; %include dialup_values;
%page; %include hashst;
dcl  htp ptr init (null);			/* needed by hashst */
%page; %include installation_parms;
%page; %include rtdt;
%page; %include sat;

dcl  satep ptr automatic init (null);			/* sat incl requires dcl of this pointer. */
%page; %include sc_stat_;
%page; %include sub_error_info;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;
 

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   as_init_: The requested action was not performed. Multics already initialized.

   S:	$as1

   T:	$init

   M:	The operator typed startup, multics, or go when Multics was already
   in operation.  No action was taken.

   A:	$ignore


   Message:
   as_init_: The requested action was not performed.  Cannot type go twice.

   S:	$as1

   T:	$init

   M:	The operator typed go when Multics was already in
   operation.  No action was taken.

   A:	$ignore


   Message:
   as_init_: ERROR_MESSAGE.  Cannot create pit_temp_

   S:	$as1

   T:	$init

   M:	The system could not create a temporary segment in the
   Answering Service process's process directory.  This is a fatal error
   that will cause answering service startup to fail.

   A:	$contact_sa


   Message:
   as_init_: Resource management is disabled; >sc1>rtdt needs it enabled.

   S:	$as1

   T:	$init

   M:	The copy of installation_parms encountered by system startup
   claims that RCP resource management is disabled.  This disagrees with
   information in the RTDT.  If startup were to continue, all information in
   resource registries would be lost.  Answering Service initialization fails.
   The system administrator must use ed_installation_parms from admin mode to
   repair the damage.  Then reboot the system.

   A:	$contact_sa


   Message:
   as_init_: SYSTEM_CONTROL_DIR>TABLE missing.  Creating new one.

   S:	$as1

   T:	$init

   M:	A new version of TABLE was created in SYSTEM_CONTROL_DIR as
   part of system initialization.

   A:	$ignore


   Message:
   as_init_: ERROR_MESSAGE.  SYSTEM_CONTROL_DIR>TABLE.  Forcing access.

   S:	$as1

   T:	$init

   M:	During system initialization, TABLE in SYSTEM_CONTROL_DIR was 
   found to have an incorrect ACL.  Access was set for Initializer.SysDaemon.

   A:	$ignore

        
   Message:
   as_init_: ERROR_MESSAGE.  Could not create SYSTEM_CONTROL_DIR>TABLE.

   S:	$as1

   T:	$init

   M:	The Initializer could not create a new segment TABLE in 
   SYSTEM_CONTROL_DIR.  Answering service initialization fails.
   The system administrator must enter admin mode, and type "create TABLE",
   where TABLE is the name given above.  Then reboot the system.

   A:	$contact_sa


   Message:
   as_init_: ERROR_MESSAGE.  Could not initiate SYSTEM_CONTROL_DIR>TABLE.

   S:	$as1

   T:	$init

   M:	The Initializer could not initiate the TABLE segment in 
   SYSTEM_CONTROL_DIR.  Answering service initialization fails.
   The system administrator must enter admin mode, and correct the problem.
   Then reboot the system.

   A:	$contact_sa


   Message:
   as_init_: ERROR_MESSAGE.  Could not force access on SYSTEM_CONTROL_DIR>TABLE.

   S:	$as1

   T:	$init

   M:	The Initializer could not change the ACL on the TABLE segment in 
   SYSTEM_CONTROL_DIR.  Answering service initialization fails.
   The system administrator must enter admin mode, and correct the problem.
   Then reboot the system.

   A:	$contact_sa


      Message:
   as_init_: ERROR_MESSAGE.  Could not set RW access on SYSTEM_CONTROL_DIR>TABLE.

   S:	$as1

   T:	$init

   M:	An error occurred attempting to add ACL entries to TABLE in 
   SYSTEM_CONTROL_DIR.  Answering Service initialization fails.  The
   system administrator must enter admin mode and correct the problem.
   Then reboot the system.

   A:	$contact_sa


   Message:
   as_init_: Multics SYSID; Answering Service VERSION

   S:	$as1

   T:	$init

   M:	Answering Service initialization is complete and users
   may now log in.  The current system version number, from the
   system tape, is SYSID.  The current Answering Service version number
   is VERSION.

   A:	Proceed with startup.


   Message:
   as_init_: ERROR_MESSAGE.  Initialization of MODULE failed.  {ADDED_INFO.}

   S:	$as1

   T:	$init

   M:	MODULE was being initialized when it detected a problem.  It
   called sub_err_ to report the error to as_init_.  ERROR_MESSAGE gives the 
   text associated with the error code MODULE returned to as_init_.  
   If present, ADDED_INFO gives further details about the problem.  Some steps
   of Answering Service initialization were not performed.  This may cause
   the system to operate incorrectly.

   A:	$contact


   Message:
   as_init_: ERROR_MESSAGE.  MODULE signalled sub_error_; 
   initialization continues.  {ADDED_INFO.}

   S:	$as1

   T:	$init

   M:	MODULE was being initialized when it detected a problem.  It
   called sub_err_ to report the error to as_init_.  ERROR_MESSAGE gives the 
   text associated with the error code MODULE returned to as_init_.  
   If present, ADDED_INFO gives further details about the problem.  
   Initialization of the module continues.

   A:	$contact.  


   Message:
   as_init_: Condition COND signalled during startup.  Taking AS dump. 
   CONDITION_INFO

   S.	$as1

   T:	$init

   M:	An unexpected condition COND occurred during system initialization.
   An answering service dump is taken.  The stack trace information in this
   dump further describes the error.    Some steps of Answering Service
   initialization were not performed.  This may cause the system to operate
   incorrectly.  CONDITION_INFO if optionally present if further information
   about the condition is available.

   A:	$contact


   Message:
   as_init_: The requested action was not performed.  Type multics first.

   S:	$as1

   T:	$init

   M:	The operator typed go without typing multics.  No
   action was taken.

   A:	Type multics first, or startup.


   Message:
   as_init_: ERROR_MESSAGE.  Error while defining initial work classes.

   S:	$as1

   T:	$init

   M:	$err
   Answering Service initialization fails.  The system administrator
   must enter admin mode and correct the problem.  Then reboot the system.

   A:	$contact_sa


   Message:
   as_init_: ERROR_MESSAGE.

   S:	$as1

   T:	$init

   M:	A fatal error occurred during Answering Service initialization.
   Previous messages describe the error in more detail.

   A:	$contact_sa


   Message:
   as_init_: Answering Service initialization failed.

   S:	$as2

   T:	$init

   M:	$err
   Answering Service initialization failed.  Normally, this message is
   preceded by a more specific indication of the reason for failure.

   A:	$contact
   Attempt to correct the problem and try startup again.


   Message:
   as_init_: This procedure does not implement the requested version.
   installation_parms version N.

   S:	$as1

   T:	$init

   M:	$err
   The installation_parms segment has been damaged or is not up-to-date.
   The system administrator must rectify the problem using 
   ed_installation_parms from admin mode, before the Answering Service
   will initialize.  It will be necessary to re-boot Multics to retry 
   Answering Serviceinitialization.

   A:	$contact_sa


   Message:
   as_init_: installation_parms damaged.  N rate structures defined;
   from I to J allowed.

   S:	$as1

   T:	$init

   M:	The installation_parms table claims to declare an unallowed number
   of rate structures.  This indicates that the table has been damaged.
   The system administrator must rectify the problem using 
   ed_installation_parms from admin mode, before the Answering Service
   will initialize.  It will be necessary to re-boot Multics to retry 
   Answering Service initialization.

   A:	$contact_sa


   Message:
   as_init_: Condition was signalled while processing another condition. CONDITION

   S:	$beep

   T:	$init

   M:	$err
   During Answering Service initialization, a CONDITION was raised while
   as_init_ was already processing some condition.  It may be that the error
   occured while making an as_dump for the first condition.  as_init_ will not
   attempt to make an as_dump, but will instead abort the initialization.

   A:	$contact


   Message:
   as_init_: SAT version inconsistent with declarations used in this program.

   S:	$as1

   T:	$init

   M:	The version number stored in the SAT does not match the
   expected version number, which is a constant in the Answering Service
   programs.  This may be because the SAT has been destroyed, or because
   an incorrect version of the Answering Service programs is being used.
   $crashes

   A:	$contact_sa
   The System Administrator must either generate a new SAT, or install the
   correct version of the Answering Service.  If the System Administrator is
   not available, enter admin mode and attempt to retrieve a
   recent copy of the SAT.  Then exit from admin mode and try startup
   again.


   Message:
   as_init_: rebuilding SAT hash table.

   S:	$as1

   T:	$init

   M:	The hash table for the SAT was corrupted. The hash table is
   regenerated.

   A:	$ignore


   Message:
   as_init_: ERROR_MESSAGE.  Cannot create sat.ht. REASON

   S:	$as1

   T:	$init

   M:	This message indicates that the sat is damaged or that a storage
   system error prevented the creation of a new hash table for the sat.
   Answering Service startup will fail.

   A:	$contact_sa


   Message:
   as_init_: No "tcd" card in the config deck. Assuming APT size of 1000.

   S:	$as1

   T:	$init

   M:	This message indicates that there is no TCD card in the config deck.
   The system will operate normally, but it is recommended that an explicit
   TCD card be added at the first convenience.

   A:	$contact_sa


   Message:
   as_init_: CDT threading inconsistency found.  Rethreading.

   S:	$as1

   T:	$init

   M:	An error was detected while tracing the threading of Channel 
   Definition Table (CDT) entries into a hierarchy of multiplexer and
   subchannel entries. $err  The entire channel hierarchy will be rethreaded.

   A:	$notify_sa


   Message:
   as_init_: CDT rethreading complete.

   S:	$as1

   T:	$init

   M:	Rethreading of Channel Definition Table (CDT) entries into a
   multiplexer/subchannel hierarchy completed successfully.  System 
   initialization continues.

   A:	$notify_sa


   Message:
   as_init_: ERROR_MESSAGE.  cdt_mgr_$thread: ADDED_INFO

   S:	$as1

   T:	$init

   M:	as_init_ called cdt_mgr_$thread to rethread the Channel Definition
   Table (CDT) entries into a multiplexer/subchannel hierarchy.  cdt_mgr_ 
   encountered an unexpected error.  ERROR_MESSAGE is the text associated with 
   the error code returned by cdt_mgr_.  ADDED_INFO further describes the 
   error and whether or not further rethreading is attempted.

   A:	$notify_sa


   Message:
   as_init_: ERROR_MESSAGE.  Repeated CDT threading inconsistencies.

   S:	$as1

   T:	$init

   M:	Channel Definition Table (CDT) entry threads were found to be
   damaged even after rethreading completed successfully.  $err

   A:	$contact_sa


   Message:
   as_init_: ERROR_MESSAGE.  Could not set priority for IPC wait channels.

   S:	$as1

   T:	$init

   M:	A call to ipc_$set_wait_prior failed.  $err

   A:	$notify_sa


   Message:
   as_init_: ERROR_MESSAGE.  Calling multiplexer_mgr_$ENTRYPOINT.

   S:	$as1

   T:	$init

   M:	The multiplexer_mgr_ failed when accessing the Channel Definition
   Table (CDT) in >sc1, initializing the CDT or loading the FNPs.
   ERROR_MESSAGE is the text associated with the error code returned by
   multiplexer_mgr_.  Answering service initialization fails.  The system
   administrator must enter admin mode and correct the problem.  Then reboot
   the system.

   A:	$contact_sa


   Message:
   as_init_: ERROR_MESSAGE.  Calling ROUTINE.

   S:	$as1

   T:	$init

   M:	An error occurred when calling ROUTINE during Answering Service
   initialization.  ERROR_MESSAGE is the text associated with the error code 
   returned by ROUTINE.  Answering service initialization fails.  The system
   administrator must enter admin mode and correct the problem.  Then reboot
   the system.

   A:	$contact_sa


   Message:
   as_init_: ERROR_MESSAGE.  Shutting down the login server request mechanism.

   S:	$as1

   T:	$shut

   M:	An error occurred while shutting down the login server request 
   mechanism.  The ERROR_MESSAGE gives the text associated with the error
   code returned from ls_request_server_$shutdown.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end as_init_;




		    as_request_bump_user_.pl1       07/13/88  1112.8r w 07/13/88  0938.4       91287



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-10-14,Lippard), approve(85-12-30,MCR7326),
     audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200):
      Use version 2 of as_request_sender.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
                                                   END HISTORY COMMENTS */

/* format: ^indcom */

/* DESCRIPTION:
   This procedure is called by as_request_server_ to request that a process be
   bumped from the system.  Privledge for a user to bump a process is
   controled by the user's access to the ACS segment: bump_user.acs in 
   as_data_$acsdir.  A grace time and a message to be sent to the user's
   terminal can be specified.  All successful and unsuccessful attempts are
   logged.

   P_asr_bump_user_info_ptr - points to the asr_bump_user_info structure which
   contains the process id of the process to be bumped, a message to be
   printed on the user's terminal, and a grace time.

   P_as_request_sender_ptr - points to the as_request_sender structure which
   describes the sender of the bump_user request.
*/

/* HISTORY:
Written by R. Michael Tague, 08/28/84.
Modified:
11/02/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.
11/20/84 by R. Michael Tague:  Added person.project.tag information to several
            error messages.  Fixed omission of code setting in
            VALIDATE_REQUESTER.  Fixed a few comments.
*/

/* format: style5 */

as_request_bump_user_:
        procedure (P_asr_bump_user_info_ptr, P_as_request_sender_ptr);

/* DECLARATIONS */
/* parameters */

        dcl     P_asr_bump_user_info_ptr
				ptr parameter;
        dcl     P_as_request_sender_ptr ptr parameter;

/* automatic */

        dcl     mode		bit (36) aligned;
        dcl     code		fixed bin (35);
        dcl     type		fixed bin;

/* builtin functions */

        dcl     (null, addr)		builtin;

/* constants */

        dcl     myname		init ("as_request_bump_user_")
				char (21) internal static
				options (constant);

/* entries */

        dcl     aim_check_$equal	entry (bit (72) aligned,
				bit (72) aligned)
				returns (bit (1) aligned);
        dcl     up_sysctl_$check_acs	entry (char (*), char (*), fixed bin,
				bit (36) aligned, fixed bin (35));
        dcl     asu_$find_process	entry (bit (36) aligned, fixed bin, ptr)
				;
        dcl     asu_$bump_user	entry (ptr, char (*), fixed bin (35),
				fixed bin);
        dcl     sys_log_		entry options (variable);
        dcl     sys_log_$error_log	entry options (variable);

/* external static */

        dcl     error_table_$ai_restricted
				fixed bin (35) external static;
        dcl     error_table_$as_bump_user_not_found
				fixed bin (35) external static;
        dcl     error_table_$as_request_invalid_request
				fixed bin (35) external static;
        dcl     error_table_$insufficient_access
				fixed bin (35) external static;

/* END OF DECLARATIONS */

/* program */
        asr_bump_user_info_ptr = P_asr_bump_user_info_ptr;
        as_request_sender_ptr = P_as_request_sender_ptr;
        call VALIDATE_REQUESTER (code);
        if code = 0 then
	      do;
	      call FIND_REQUESTEE_AND_DO_AIM_CHECK (code);
	      if code = 0 then
		    call REGISTER_FOR_BUMP (code);
	      end;
        asr_replyp = addr (as_request_sender.reply_message);
        asr_reply_bump_user.reference_id =
	  asr_bump_user_info.reply_reference_id;
        asr_reply_bump_user.code = code;
        return;

/* ************************************************************************
   * VALIDATE_REQUESTER - This routine checks the requester's access to   *
   * the ACS segment: bump_user.acs in as_data_$acsdir.  The requester    *
   * must have read/write access.  This routine also checks structure     *
   * versions.						    *
   ************************************************************************ */

VALIDATE_REQUESTER:
        proc (code);
        dcl     code		fixed bin (35);

        if asr_bump_user_info.version = asr_bump_user_info_version_1
	  & as_request_sender.version = AS_REQUEST_SENDER_VERSION_2 then
	      do;
	      call up_sysctl_$check_acs ("bump_user.acs",
		as_request_sender.group_id,
		(as_request_sender.validation_level), mode, code);
	      if code = 0 then
		    if (mode & RW_ACCESS) = RW_ACCESS then
			  ;		      /* Access is ok */
		    else
			  do;
			  code = error_table_$insufficient_access;
			  call sys_log_$error_log (SL_LOG_SILENT, code,
			      myname,
			      "Rejected BUMP_USER request from ^a to bump process ^12.3b.  Requestor does not have sufficient access to the bump_user.acs segment.",
			      as_request_sender.group_id,
			      asr_bump_user_info.process_id);
			  end;
	      else
		    call sys_log_$error_log (SL_LOG_SILENT, code, myname,
		        "Rejected BUMP_USER request from ^a to bump process ^12.3b.  Error calling up_sysctl_$check_acs for requestor.",
		        as_request_sender.group_id,
		        asr_bump_user_info.process_id);
	      end;
        else
	      do;
	      code = error_table_$as_request_invalid_request;
	      call sys_log_$error_log (SL_LOG_SILENT, code, myname,
	         "Rejected BUMP_USER request from ^a to bump process ^12.3b.  Invalid version (^[^a^s^;^s^a^]) in the ^[asr_bump_user_info^;as_request_sender^] structure.",
		as_request_sender.group_id, asr_bump_user_info.process_id,
		(asr_bump_user_info.version ^= asr_bump_user_info_version_1),
	          asr_bump_user_info.version, as_request_sender.version,
		(asr_bump_user_info.version ^= asr_bump_user_info_version_1));
	      end;
        end VALIDATE_REQUESTER;

/* *************************************************************************
   * FIND_REQUESTEE_AND_DO_AIM_CHECK - Find the process to be bumped in    *
   * the user_table and check that the AIM level of the requester and the  *
   * AIM level of the process to be bumped are equal.  This AIM check      *
   * prevents a covert channel between the requester and requestee which   *
   * could be quite large given that a message specified by the requester  *
   * is sent to the user to be bumped.				     *
   *							     *
   * This routine sets the user_table base pointer, utep.		     *
   ************************************************************************* */

FIND_REQUESTEE_AND_DO_AIM_CHECK:
        proc (code);
        dcl     code		fixed bin (35);

        call asu_$find_process (asr_bump_user_info.process_id, type, utep);
        if utep = null then
	      do;
	      code = error_table_$as_bump_user_not_found;
	      call sys_log_$error_log (SL_LOG_SILENT, code, myname,
		"Rejected BUMP_USER request from ^a to bump process ^12.3b.  Process to be bumped was not found.",
		as_request_sender.group_id, asr_bump_user_info.process_id);
	      end;
        else
	      do;
	      if aim_check_$equal (as_request_sender.authorization,
		ute.process_authorization) then
		    code = 0;
	      else
		    do;
		    code = error_table_$ai_restricted;
		    call sys_log_$error_log (SL_LOG_SILENT, code, myname,
		        "Rejected BUMP_USER request from ^a to bump process ^12.3b (^[*^]^a.^a.^a).  Authorization level of requesting process and target process do not match.",
		        as_request_sender.group_id, 
		        asr_bump_user_info.process_id, ute.anonymous,
		        ute.person, ute.project, ute.tag);
		    end;
	      end;
        end FIND_REQUESTEE_AND_DO_AIM_CHECK;

/* *************************************************************************
   * REGISTER_FOR_BUMP - Call asu_$bump_user to get the process registered *
   * for a bump to occur at grace time in the future.  Logs request.	     *
   ************************************************************************* */

REGISTER_FOR_BUMP:
        proc (code);
        dcl     code		fixed bin (35);

        call asu_$bump_user (utep, asr_bump_user_info.message, code,
	  asr_bump_user_info.grace_time_in_seconds);
        if code = 0 then
	      call sys_log_ (SL_LOG_SILENT,
		"^a: BUMPING ^[*^]^a.^a.^a ^12.3b for requestor ^a.",
		myname, ute.anonymous,
		ute.person, ute.project, ute.tag,
		asr_bump_user_info.process_id,
		as_request_sender.group_id);
        else
	      call sys_log_$error_log (SL_LOG_SILENT, code, myname,
		"Rejected BUMP_USER request from ^a to bump process ^12.3b (^[*^]^a.^a.^a).  Error from asu_$bump_user.",
		as_request_sender.group_id, asr_bump_user_info.process_id,
		ute.anonymous, ute.person, ute.project, ute.tag);
        end REGISTER_FOR_BUMP;

%page;
%include access_mode_values;
%page;
%include as_request_header;
%page;
%include as_requests;
%page;
%include as_request_sender_;
%page;
%include sys_log_constants;
%page;
%include user_attributes;
%page;
%include user_table_entry;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   as_request_bump_user_: ERROR_MSG. Rejected BUMP_USER request from 
   PERS.PROJ.TAG to bump process PROCESS_ID. REASON

   S:	as (severity 0)

   T:	$run

   M:	The answering service request from PERS.PROJ.TAG to bump the process
   identified by PROCESSID failed for the given REASON and ERROR_MSG.

   A:	$contact_sa

   Message:
   as_request_bump_user_: BUMPING PERS.PROJ.TAG PROCESSID for requestor 
   REQ_PERS.REQ_PROJ.REQ_TAG.

   S:	as (severity 0)

   T:	$run

   M:	An answering service request from REQ_PERS.REQ_PROJ.REQ_TAG to bump
   the process PERS.PROJ.TAG PROCESSID has been initiated.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

        end as_request_bump_user_;




		    as_request_note_pnt_change_.pl1 08/29/88  0950.7rew 08/29/88  0858.7      139455



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: off */

as_request_note_pnt_change_:
     procedure (P_asr_note_pnt_change_info_ptr, P_asr_sender_ptr);

/**** This procedure in invoked by as_request_server_ upon receipt of
      an answering service request of type NOTE_PNT_CHANGE.  This request
      is used by the Ring-1 PNT software to notify the answering service
      of security relevant changes to the PNT.  */

/* 
   Modification History:
   Written 1985-01-23 by E. Swenson.
*/

/****^  HISTORY COMMENTS:
  1) change(86-10-14,Lippard), approve(85-12-30,MCR7326),
     audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200):
      Modified to use version 2 as_request_sender.
  2) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  3) change(87-07-24,Dickson), approve(87-07-24,MCR7722),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Changed the VALIDATE_REQUEST procedure to audit grants as well as
     failures.
  4) change(87-12-03,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) Modify UPDATE_UTE_AND_MAYBE_BUMP_USER to bump the user if his
         password is time-locked.  A prior modification had bumped the user
         if his password was locked, but time-locking was overlooked.  See
         aref of ii.forum [782] for details.  A TR may be entered on this
         subject.  This change deserves and SRB NOTICE.
      B) Modify BUMP_USER to honor the ute.at.nobump attribute for all
         bump attempted except deletion of the user's PNT entry.  For password
         locking and authorization range changes, users with nobump should
         not be bumped immediately.  Reason: such users are usually System
         Administrators attempting to thwart breakin attempts on their
         personid, or to adjust their own auth ranges; they should not be
         bumped in such cases.
                                                   END HISTORY COMMENTS */

/* Parameters */

dcl P_asr_note_pnt_change_info_ptr ptr parameter;
dcl P_asr_sender_ptr ptr parameter;

/* Automatic */

dcl code fixed bin (35); /* status code */
dcl person_id char (32); /* person_id we are processing */

/* Entries */ 

dcl aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl as_access_audit_$as_rqt_nt_pnt_chg entry (char (*), ptr, fixed bin (35));
dcl as_any_other_handler_ entry (char(*), entry, label, label);
dcl asu_$blast_user entry (ptr, char(*), char(*), fixed bin(35));
dcl asu_$bump_user entry (ptr, char(*), fixed bin(35), fixed bin);
dcl display_access_class_ entry (bit (72) aligned) returns (char (32) aligned);
dcl pnt_manager_$admin_get_entry entry (char (*), ptr, fixed bin (35));
dcl sys_log_ entry options (variable);
dcl sys_log_$error_log entry options (variable);

/* External */

dcl error_table_$id_not_found fixed bin (35) external static;
dcl error_table_$not_privileged fixed bin (35) external static;
dcl error_table_$unimplemented_version fixed bin (35) external static;

/* Builtins */

dcl (addr, clock, null) builtin;

/* Constants */

dcl (DO_HONOR_NOBUMP initial ("1"b),
     DONT_HONOR_NOBUMP initial ("0"b)) bit(1) int static options(constant);
dcl ME char (32) initial ("as_request_note_pnt_change_") internal static options (constant);
dcl RING_1 fixed bin (3) initial (1) internal static options (constant);

/* Conditions */

dcl any_other condition;
%page;
/* Program */

/**** Since we are using as_data_ pointers, ensure they have been
      initialized before proceeding.  If they haven't, return
      with no logging because the answering service must not have
      been initialized properly.  This should never happen though. */

      if as_data_$ansp = null () | as_data_$autp = null () |
	 as_data_$dutp = null ()
      then return;
      ansp = as_data_$ansp;
      autp = as_data_$autp;
      dutp = as_data_$dutp;
      

/**** First, establish an any other handler in case of faults */

     on any_other 
	call as_any_other_handler_ (ME, NULL_PROC, MAIN_RETURN, MAIN_RETURN);

/**** Copy arguments into automatic storage */

     asr_note_pnt_change_info_ptr = P_asr_note_pnt_change_info_ptr;
     as_request_sender_ptr = P_asr_sender_ptr;

/**** Validate the request in terms of access and reasonability of data */

     call VALIDATE_REQUEST (code);
     if code = 0 then
	do;
	person_id = asr_note_pnt_change_info.person_id;
	call SCAN_USER_TABLES_AND_UPDATE ();
	end;
     else; /* we've already logged any errors */

MAIN_RETURN:
    return;
%page;
VALIDATE_REQUEST:
     procedure (P_code);

dcl P_code fixed bin (35) parameter;

/**** Validate the request.  Check the version numbers of the structures
      and verify that the request came from Ring-1.  Log any invalid 
      requests */

     if as_request_sender.version ^= AS_REQUEST_SENDER_VERSION_2 then do;
	P_code = error_table_$unimplemented_version;
	call sys_log_$error_log (SL_LOG_SILENT, P_code, ME,
	     "Rejected NOTE_PNT_CHANGE request from ^a.  Invalid version (^a) in as_request_sender structure.",
	     as_request_sender.group_id, as_request_sender.version);
	return;
	end;
     else if asr_note_pnt_change_info.version ^= ASR_NPC_INFO_VERSION_1 then do;
	P_code = error_table_$unimplemented_version;
	call sys_log_$error_log (SL_LOG_SILENT, P_code, ME,
	     "Rejected NOTE_PNT_CHANGE request from ^a.  Invalid version number (^a) in asr_note_pnt_change_info structure.",
	     as_request_sender.group_id, asr_note_pnt_change_info.version);
	return;
	end;

			/* Check access after we've determined that */
			/* the data is correct for checking access. */

     if as_request_sender.validation_level ^= RING_1 then P_code = error_table_$not_privileged;
     else P_code = 0; /* request is ok */

     call as_access_audit_$as_rqt_nt_pnt_chg (ME, addr(as_request_sender), P_code);

     return;

end VALIDATE_REQUEST;
%page;
SCAN_USER_TABLES_AND_UPDATE:
     procedure ();

/**** Scan the answer table, daemon user table, and absentee user table 
      logged in processes for the specified personid.  If any are found,
      get the new pnt entry and update the info in the user tables, 
      bumping any processes which are incompatible with the new PNT entry. */

dcl pnt_entry_status fixed bin(2); /* tells us whether we've retrieved the PNT entry yet */
dcl (PNT_ENTRY_NOT_RETRIEVED  init(0),
     PNT_ENTRY_RETRIEVED      init(1),
     PNT_ENTRY_DELETED        init(2),
     PNT_ENTRY_RETRIEVE_ERROR init(3)) fixed bin(2) int static options(constant);
dcl i fixed bin (17); /* index into user_table_entry array */

      pnt_entry_status = PNT_ENTRY_NOT_RETRIEVED;

/**** Scan interactive user table (answer_table) */
      do i = 1 to anstbl.current_size;
	 utep = addr (anstbl.entry (i));
	 call PROCESS_UTE ();
      end;
/**** Scan absentee user table */
      do i = 1 to autbl.current_size;
	 utep = addr (autbl.entry (i));
	 call PROCESS_UTE ();
      end;
/**** Scan daemon user table */
      do i = 1 to dutbl.current_size;
	 utep = addr (dutbl.entry (i));
	 call PROCESS_UTE ();
      end;
     return;

PROCESS_UTE:
     procedure ();

dcl 1 pnte aligned like pnt_entry automatic;

     if ute.active = NOW_HAS_PROCESS
     then if ute.person = person_id
	then do;
	     if pnt_entry_status = PNT_ENTRY_NOT_RETRIEVED 
	     then call RETRIEVE_PNT_ENTRY ();
	     if pnt_entry_status = PNT_ENTRY_DELETED /* user deleted */
	     then call BUMP_USER ("Deleted from PNT", DONT_HONOR_NOBUMP);
	     else if pnt_entry_status = PNT_ENTRY_RETRIEVED
		then call UPDATE_UTE_AND_MAYBE_BUMP_USER ();
		else; /* error from RETRIEVE_PNT_ENTRY */
	end;
	else; /* non matching person_id */
     else; /* non active process */
     return;

RETRIEVE_PNT_ENTRY:
     procedure ();

     call pnt_manager_$admin_get_entry (person_id, addr (pnte), code);
     if code = error_table_$id_not_found 
     then pnt_entry_status = PNT_ENTRY_DELETED;
     else if code ^= 0
	then do;
	     call sys_log_$error_log (SL_LOG_SILENT, code, ME,
		"Unable to retrieve PNT entry for ^a.", person_id);
	     pnt_entry_status = PNT_ENTRY_RETRIEVE_ERROR;
	end;
	else pnt_entry_status = PNT_ENTRY_RETRIEVED; /* everything is ok */
     return;

end RETRIEVE_PNT_ENTRY;


BUMP_USER:
     procedure (P_reason, honor_nobump);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Bump this user since his PNT entry was deleted or password was locked.    */
/*							       */
/* Bump will be prevented if password being locked and the user has nobump   */
/* attribute.  Usually this is the System Administrator locking his own      */
/* password to thwart a break-in attempt.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl P_reason char (*) parameter;		/* reason for bumping      */
dcl honor_nobump bit(1) parameter;		/* on: nobump stops bumping*/
dcl NO_GRACE fixed bin (17) initial (0) internal static options (constant);

     if honor_nobump & ute.at.nobump then do;
	call sys_log_ (SL_LOG_SILENT,
	     "^a: User has ""nobump"" attribute.  Did not bump ^a.^a.^a ^12.3b on channel ^a (^a)",
	     ME, ute.person, ute.project, ute.tag, ute.proc_id, ute.tty_name,
	     P_reason);
	if ^ute.uflags.disconnected then
	     call asu_$blast_user (utep,
	     """nobump"" attribute prevented bump attempt when: " ||
	     P_reason, (""), (0));
	end;

     else do;
	call sys_log_ (SL_LOG_SILENT, 
	     "^a: Bumping user ^a.^a.^a ^12.3b on channel ^a (^a)",
	     ME, ute.person, ute.project, ute.tag, ute.proc_id, ute.tty_name,
	     P_reason);

	call asu_$bump_user (utep, P_reason, code, NO_GRACE);
	if code ^= 0 then
	     call sys_log_$error_log (SL_LOG_SILENT, code, ME,
	     "Error from asu_$bump_user.  Did not bump ^a.^a.^a ^12.3b on channel ^a (^a)",
	     ute.person, ute.project, ute.tag, ute.proc_id, ute.tty_name,
	     P_reason);
	end;

end BUMP_USER;


UPDATE_UTE_AND_MAYBE_BUMP_USER:
     procedure ();

     if pnte.flags.lock /* user's password has been locked */
     then call BUMP_USER ("Password locked", DO_HONOR_NOBUMP);
     else if pnte.flags.pw_time_lock then
          if clock() <= pnte.password_timelock then
	     call BUMP_USER ("Password time_locked", DO_HONOR_NOBUMP);
	else go to OTHER_TESTS;
     else do;
OTHER_TESTS:
	if pnte.person_authorization (2) 
	     < ute.process_authorization_range (2) /* lowered max auth */
	then do;
	     call sys_log_ (SL_LOG_SILENT,
		"^a: Lowered maximum authorization for ^a.^a.^a on channel ^a from ^a to ^a.  PNT change.",
		ME, ute.person, ute.project, ute.tag, ute.tty_name,
		display_access_class_ (ute.process_authorization_range (2)),
		display_access_class_ (pnte.person_authorization (2)));
	     ute.process_authorization_range (2) = pnte.person_authorization (2);
	     end;
	else;
	if pnte.person_authorization (1)
	     > ute.process_authorization_range (1) /* raised min auth */
	then do;
	     call sys_log_ (SL_LOG_SILENT,
		"^a: Raised minimum authorization for ^a.^a.^a on channel ^a from ^a to ^a.  PNT change.",
		ME, ute.person, ute.project, ute.tag, ute.tty_name,
		display_access_class_ (ute.process_authorization_range (1)),
		display_access_class_ (pnte.person_authorization (1)));
	     ute.process_authorization_range (1) = pnte.person_authorization (1);
	     end;
	else;
	if ^aim_check_$in_range (ute.process_authorization, ute.process_authorization_range)
	then call BUMP_USER ("Authorization range changed by System Administrator", DO_HONOR_NOBUMP);
	else;
	end;
     return;
end UPDATE_UTE_AND_MAYBE_BUMP_USER;

end PROCESS_UTE;

end SCAN_USER_TABLES_AND_UPDATE;
%page;
NULL_PROC:
     procedure ();

/**** This is a dummy cleanup handler, for as_any_other_handler_'s sake.
      It does nothing, but is required by as_any_other_handler_. */

     return;
end NULL_PROC;

/* format: off */
%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_request_header;
%page; %include as_request_sender_;
%page; %include as_requests;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include pnt_entry;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   as_request_note_pnt_change_: ERROR_MSG.  Rejected NOTE_PNT_CHANGE request
   from PERS.PROJ.  REASON
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	An answering service request to note a change to the PNT sent
   by PERS.PROJ failed because of REASON.  $err
   
   A:	$contact

   Message:
   as_request_note_pnt_change_: ERROR_MSG. Unable to retrieve PNT entry for 
   PERS.
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	An error (ERROR_MSG) occurred while getting the PNT entry for person
   PERS.
   
   A:	$contact_sa
   
   Message:
   as_request_note_pnt_change_: Bumping user PERS.PROJ.TAG PROCESSID on
   channel CHN. (REASON)
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	Process PERS.PROJ.TAG on channel CHN was bumped by a change to the 
   PNT entry for PERS.  REASON describes the type of PNT change.
   
   A:	$ignore

   Message:
   as_request_note_pnt_change_: ERROR_MSG. Error from asu_$bump user.
   Did not bump PERS.PROJ.TAG PROCESSID on channel CHN (REASON)
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	An error occurred attempting to bump process PERS.PROJ.TAG PROCESSID
   on channel CHN.  REASON indicates why bumping was attempted.
   
   A:	$contact_sa
   
   Message:
   as_request_note_pnt_change_: User has "nobump" attribute.
   Did not bump PERS.PROJ.TAG PROCESSID on channel CHN. (REASON)
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	Bump attempt for process PERS.PROJ.TAG with PROCESSID on channel CHN
   failed, because the user has the nobump attribute.  REASON indicates why 
   bumping was attempted.
   
   A:	$contact_sa


   Message:
   as_request_note_pnt_change_: Lowered maximum authorization for PERS.PROJ.TAG
   on channel CHN from OLD_MAX_AUTH to NEW_MAX_AUTH.  PNT change.
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	A change to the PNT entry for PERS lowered the maximum authorization
   associated with the process PERS.PROJ.TAG on channel CHN.  The
   authorization was changed from OLD_MAX_AUTH to NEW_MAX_AUTH.
   
   A:	$ignore

   Message:
   as_request_note_pnt_change_: Raised minimum authorization for PERS.PROJ.TAG
   on channel CHN from OLD_MIN_AUTH to NEW_MIN_AUTH.  PNT change.
   
   S:	as (severity 0)
   
   T:	$run
   
   M:	A change to the PNT entry for PERS raised the minimum authorization
   associated with the process PERS.PROJ.TAG on channel CHN.  The
   authorization was changed from OLD_MIN_AUTH to NEW_MIN_AUTH.
   
   A:	$ignore

   END MESSAGE DOCUMENTATION */

/* format: on */

end as_request_note_pnt_change_;




		    as_request_server_.pl1          09/06/88  1302.0rew 09/06/88  1300.7      280746



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

/* DESCRIPTION:
   A procedure to get requests from user processes and dispatch
   them to the correct answering service module.
*/

/* HISTORY:
   Written by Paul Green, 01/09/75.
   Modified:
   04/01/79 by T. Casey: to correctly handle requests from foreground
   or proxy absentee processes.
   12/01/80 by E. N. Kittlitz: to set anstbl.current_time on wakeup.
   06/01/81 by T. Casey: for MR9.0 for new wakeup priorities.
   11/01/81 by E. N. Kittlitz: user_table_entry conversion.
   04/01/82 by E. N. Kittlitz: New AS initialization. bugfixes.
   10/01/82 by E. N. Kittlitz: Rename as_request_ to as_request_server_,
   add requests 3 - 5.
   04/04/84 by Benson I. Margulies: Changed to pass as_request_sender instead
   of event_call_info.
   08/23/84 by R. Michael Tague:  Added ASR_BUMP_USER request.  Added length
   checks of structures passed from the message segment.  Fixed bug with
   ASR_FPE_CAUSES_(LOGOUT NEW_PROC) request, it was not replying correctly.
   Structured $wakeup entry.
   Modified 1984-10-04 BIM for ASR_ADMIN_COMMAND, V5 msegs.
   Modified 1984-10-29 by E. Swenson to fix bug which caused asdumps when
   invalid messages were processed.
   11/20/84 by R. Michael Tague:  Fixed a few error comments.  Added named 
   access constants.  Changed to use ute.tag.
   Modified 1985-01-23 by E. Swenson to ASR_NOTE_PNT_CHANGE and delete
   offending message in the cleanup code.
   Modified 1985-02-19, BIM: ASR_DAEMON_COMMAND and ASR_COM_CHANNEL_INFO.
   Modified 1985-02-22 by E. Swenson to do replies properly for the 
   ASR_DAEMON_COMMAND and ASR_COM_CHANNEL_INFO requests.
   Modified 86-04-08 by SGH (UNCA) to free processed messages -- phx20268.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-12,Lippard), approve(85-12-30,MCR7326),
     audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200):
     Modified 12 December 1985 (above date to satisfy hcom)
     by Jim Lippard:  Added the ASR_ABS_COMMAND request.
  2) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  3) change(86-09-26,GDixon), approve(86-09-26,MCR7499),
     audit(86-10-09,Lippard), install(86-10-28,MR12.0-1200):
     Modified by Steve Harris (Univ. of Calgary) to free processed messages in
     all cases.  One path through the code missed freeing the message, causing
     the Initializers user free area to fill up, thereby degrading response.
  4) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  5) change(87-08-31,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
      A) Add acl for administrators to as_request.ms during initialization.
         (Answering_Service 407, phx19057)
      B) Use fs_util_ to replace the ACL, with its more modern ACL
         structures.
      C) Use mseg_access_mode_values.incl.pl1 to set access mode values,
         rather than literal constants.
  6) change(88-09-01,GDixon), approve(88-09-01,PBF7969),
     audit(88-09-03,Beattie), install(88-09-06,MR12.2-1100):
      A) Fix bug which set null access for *.*.*, instead of ao access.
         (Answering_Service 407, phx19057)
      B) Correct error message documentation.
                                                   END HISTORY COMMENTS */

/* format: style2 */

as_request_server_$init:
     procedure;

/* parameters */

	dcl     bv_event_call_info_ptr ptr parameter;

/* automatic */

	dcl     code		 fixed bin (35);
	dcl     code_mask_ev_calls	 fixed bin (35);
	dcl     code_unmask_ev_calls	 fixed bin (35);
	dcl     fixed_bin_71_reply	 fixed bin (71) aligned;
	dcl     type		 fixed bin;
	dcl     user_free_area_ptr	 ptr;

	dcl     1 mmi		 aligned like mseg_message_info;
	dcl     1 l_asr_reply	 aligned like asr_reply;
	dcl     1 l_as_request_sender	 aligned like as_request_sender;

/* internal static */

	dcl     ms_index		 fixed bin initial (0) internal static;

/* external static */

	dcl     error_table_$no_message
				 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) external static;
	dcl     error_table_$out_of_sequence
				 fixed bin (35) external static;
	dcl     error_table_$as_request_sender_missing
				 fixed bin (35) external static;
	dcl     error_table_$as_request_invalid_request
				 fixed bin (35) external static;
						/* entries */

	dcl     asu_$find_process	 entry (bit (36) aligned, fixed bin, ptr);
	dcl     as_any_other_handler_	 entry (character (*), entry, label, label);
	dcl     as_request_note_pnt_change_
				 entry (ptr, ptr);
	dcl     as_request_bump_user_	 entry (ptr, ptr);
	dcl     asr_abs_command_server_
				 entry (ptr, ptr);
	dcl     asr_com_channel_info_srvr_
				 entry (ptr, ptr);
	dcl     asr_daemon_command_server_
				 entry (ptr, ptr);
	dcl     dpg_$register_buzzard	 entry (ptr, ptr);
	dcl     dial_ctl_$dial_out_rq	 entry (ptr, ptr);
	dcl     dial_ctl_$dial_rq	 entry (ptr, ptr);
	dcl     fs_util_$replace_acl	 entry (char(*), char(*), ptr, bit(1), fixed bin(35));
	dcl     get_group_id_	 entry () returns (char (32));
	dcl     get_process_id_	 entry () returns (bit (36));
	dcl     get_user_free_area_	 entry returns (pointer);
	dcl     hcs_$wakeup		 entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
	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));
	dcl     ipc_$unmask_ev_calls	 entry (fixed bin (35));
	dcl     message_segment_$create
				 entry (char (*), char (*), fixed bin (35));
	dcl     message_segment_$delete
				 entry (char (*), char (*), fixed bin (35));
	dcl     message_segment_$delete_index
				 entry (fixed bin, bit (72) aligned, fixed bin (35));
	dcl     message_segment_$read_message_index
				 entry (fixed bin, pointer, pointer, fixed bin (35));
	dcl     message_segment_$get_message_count_index
				 entry (fixed bin, fixed bin, fixed bin (35));
	dcl     message_segment_$open	 entry (char (*), char (*), fixed bin, fixed bin (35));
	dcl     sc_admin_command_	 entry (ptr, ptr);
	dcl     sub_err_		 entry () options (variable);
	dcl     sys_log_		 entry options (variable);
	dcl     sys_log_$error_log	 entry options (variable);

/* based */

	dcl     1 request		 aligned based (mmi.ms_ptr) like as_request_header;
     	dcl     user_free_area	 area based (user_free_area_ptr);

/* builtin functions */

	dcl     (addr, clock, dimension, length, null, unspec)
				 builtin;

	dcl     cleanup		 condition;
	dcl     any_other		 condition;


/* program */

	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed
	then call sub_err_ (error_table_$out_of_sequence, "as_request_server_$init", "s");

/* Drain message segment by deleting and re-creating it. */

	call message_segment_$delete (sysdir, "as_request.ms", code);
	if code ^= 0
	then if code ^= error_table_$noentry		/* don't care if it didn't exist before */
	     then call sys_log_$error_log (SL_LOG, code, "as_request_server_$init", "Deleting ^a>as_request.ms.",
		     sysdir);

	call message_segment_$create (sysdir, "as_request.ms", code);
	if code ^= 0
	then go to fail;

	call message_segment_$open (sysdir, "as_request.ms", ms_index, code);
	if code ^= 0
	then go to fail;

/* add everyone to the ACL */

	call Set_Mseg_Acls();

/* The request segment is ready, set up the event channel */

	call ipc_$create_ev_chn (whotab.request_channel, code);
	if code ^= 0
	then go to ipc_fail;

	call ipc_$decl_ev_call_chn (whotab.request_channel, as_request_server_$wakeup, null, AS_REQUEST_PRIO, code);
	if code ^= 0
	then do;
ipc_fail:
		whotab.request_channel = 0;
		go to fail;
	     end;
	ansp = as_data_$ansp;
	whotab.request_process_id = anstbl.as_procid;

	return;

fail:
	call sys_log_$error_log (SL_LOG, code, "as_request_server_$init",
	     "Manipulating ^a>as_request.ms or IPC channels.", sysdir);
	ms_index = 0;				/* we didn't really finish */
	call sub_err_ (code, "as_request_server_$init", "s");

Set_Mseg_Acls:
     procedure ();

dcl  1 ms_acl	        aligned,			/* like general_acl */
       2 version	        char (8) aligned,
       2 count	        fixed bin,
       2 entries	        (5) like general_acl_entry;
dcl  NO_SYSDAEMON	        bit (1) initial ("1"b) internal static options (constant);

	acl_ptr = addr (ms_acl);
	general_acl.version = GENERAL_ACL_VERSION_1;
	general_acl.count = dimension (ms_acl.entries, 1);
	general_acl.entries (1).access_name = get_group_id_ ();
	general_acl.entries (1).mode = MSEG_QUEUE_CREATOR_INITIAL_ACCESS;
	general_acl.entries (1).status_code = 0;
	general_acl.entries (2).access_name = "*.SysDaemon.*";
	general_acl.entries (2).mode = MSEG_QUEUE_SYSDAEMON_INITIAL_ACCESS;
	general_acl.entries (2).status_code = 0;
	general_acl.entries (3).access_name = "*.SysAdmin.*";
	general_acl.entries (3).mode = MSEG_QUEUE_ADMIN_ACCESS;
	general_acl.entries (3).status_code = 0;
	general_acl.entries (4).access_name = "*.SysMaint.*";
	general_acl.entries (4).mode = MSEG_QUEUE_ADMIN_ACCESS;
	general_acl.entries (4).status_code = 0;
	general_acl.entries (5).access_name = "*.*.*";
	general_acl.entries (5).mode = MSEG_QUEUE_USER_ACCESS;
	general_acl.entries (5).status_code = 0;

	call fs_util_$replace_acl (sysdir, "as_request.ms",
	     addr (general_acl), NO_SYSDAEMON, code);
	if code ^= 0 then go to fail;
     end Set_Mseg_Acls;

/* ************************************************************************
   * as_request_server_$wakeup - Entry which is called when someone       *
   * places a request in the message segment and sends us a wakeup.       *
   *							    *
   * Note:  Since the messages from the requestor can be of any size, the *
   * length of the message must be compared against the size of structure *
   * that the message should represent.				    *
   ************************************************************************ */

as_request_server_$wakeup:
     entry (bv_event_call_info_ptr);
	event_call_info_ptr = bv_event_call_info_ptr;

	if ms_index = 0 | sc_stat_$shutdown_typed
	then do;
		call sys_log_ (SL_LOG,
		     "as_request_server_: Request message segment not initialized or shutdown has been typed.");
		return;
	     end;

	code_mask_ev_calls, code_unmask_ev_calls = -1;	/* close window, see CLEANUP and ERROR_RETURN */
	asr_replyp = addr (l_asr_reply);
	unspec (asr_reply) = ""b;

	unspec (mmi) = ""b;
	mmi.version = MSEG_MESSAGE_INFO_V1;
	mmi.ms_ptr = null ();			/* for cleanup handler */
	user_free_area_ptr = get_user_free_area_();
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();
	on cleanup call CLEANUP;

	call ipc_$mask_ev_calls (code_mask_ev_calls);

	on any_other call as_any_other_handler_ ("as_request_server_", CLEANUP, ERROR_RETURN, ERROR_RETURN);
						/* we have no different exit requirements when cleanup failed. */

	code = 0;
	call ipc_$drain_chn (event_call_info.channel_id, (0));
	call PROCESS_MESSAGES (code);			/* returns -2 for deferred */

/**** Here if mseg is empty, or only contains deferred messages,
      or we have burned a bunch of CPU time. */

	if code = -2				/* deferred or processed too many. */
	then call hcs_$wakeup (get_process_id_ (), whotab.request_channel, (0), (0));
	go to RETURN;

ERROR_RETURN:
	call hcs_$wakeup (get_process_id_ (), whotab.request_channel, (0), (0));
						/* in case there is work left to do. */
RETURN:
	if code_mask_ev_calls = 0 & code_unmask_ev_calls ^= 0
	then call ipc_$unmask_ev_calls (code_unmask_ev_calls);
						/* masked in initialize */
	return;


PROCESS_MESSAGES:
     proc (code);
	dcl     code		 fixed bin (35);
	dcl     deferred_one	 bit (1) aligned;
	dcl     action		 fixed bin;
	dcl     message_count	 fixed bin;

/**** Each message is either processed, deferred, or rejected */

	declare (
	        PROCESS		 init (1),
	        DEFER		 init (2),
	        REJECT		 init (3)
	        )			 fixed bin int static options (constant);

	deferred_one = "0"b;
	mmi.message_code = MSEG_READ_FIRST;		/* start with the first one */

	do while ("1"b);				/* exit with return statement */
	     call message_segment_$read_message_index (ms_index, addr(user_free_area), addr (mmi), code);
	     if code ^= 0
	     then do;
		     if code ^= error_table_$no_message
		     then call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_",
			     "Error reading message from message segment.");
		     if deferred_one
		     then code = -2;		/* note that wakeup needs to be sent back to us */
		     return;
		end;

	     action = EXAMINE_MESSAGE ();		/* side effects are potentially utep and mmi.sender_id */
	     if action = PROCESS
	     then do;
		     call PROCESS_THE_MESSAGE;
		     call DELETE_THE_MESSAGE;
		     call FREE_THE_MESSAGE;
		     call message_segment_$get_message_count_index (ms_index, message_count, code);
		     if code ^= 0 /* ???, but be safe */ | message_count > 0
		     then code = -2;
		     else code = 0;			/* There is no race condition here. */
		     return;			/* We drain the channel first, so that if we return zero here and a new message is in */
						/* its wakeup will take. */
		end;
	     else if action = DEFER
	     then do;
		     deferred_one = "1"b;
		     mmi.message_code = MSEG_READ_AFTER_SPECIFIED;
						/* continue along */
		end;
	     else if action = REJECT
	     then do;
		     call DELETE_THE_MESSAGE;
		     mmi.message_code = MSEG_READ_FIRST;
		end;

	     call FREE_THE_MESSAGE;
	end;

/* Never exit this loop */

EXAMINE_MESSAGE:
     procedure returns (fixed bin);

	if mmi.ms_len < length (unspec (request))
	then do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_",
		     "Message too short from ^a.", mmi.sender_id);
		return (REJECT);
	     end;
	call asu_$find_process (mmi.sender_process_id, type, utep);
						/* for now, always require live sender. */
	if utep = null
	then do;
		code = error_table_$as_request_sender_missing;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_",
		     "Process no longer active for request from ^a.", mmi.sender_id);
		return (REJECT);
	     end;

	if request.type < ASR_FIRST_TYPE | request.type > ASR_LAST_TYPE
	then do;
		call sys_log_ (SL_LOG_SILENT, "as_request_server_: Rejected invalid type ^d message from ^a ^w.",
		     request.type, mmi.sender_id, mmi.sender_process_id);
		return (REJECT);
	     end;

	if sc_stat_$admin_listener_switch
	then if ASR_DEFER_IN_ADMIN_MODE (request.type)
	     then return (DEFER);

	return (PROCESS);
     end EXAMINE_MESSAGE;


PROCESS_THE_MESSAGE:
     procedure;

	l_as_request_sender.version = AS_REQUEST_SENDER_VERSION_2;
	l_as_request_sender.group_id = mmi.sender_id;
	l_as_request_sender.process_id = mmi.sender_process_id;
	l_as_request_sender.authorization = mmi.sender_authorization;
	l_as_request_sender.validation_level = mmi.sender_level;
	l_as_request_sender.max_authorization = mmi.sender_max_authorization;
	l_as_request_sender.audit_flags = mmi.sender_audit;

	if request.type = ASR_DIAL_SERVER
	then call DIAL_SERVER_REQUEST ();
	else if request.type = ASR_DIAL_OUT
	then call DIAL_OUT_REQUEST ();
	else if request.type = ASR_FPE_CAUSES_LOGOUT
	then call FPE_CAUSES_LOGOUT_REQUEST ();
	else if request.type = ASR_FPE_CAUSES_NEW_PROC
	then call FPE_CAUSES_NEW_PROC_REQUEST ();
	else if request.type = ASR_PROC_TERM_NOTIFY
	then call PROC_TERM_NOTIFY_REQUEST ();
	else if request.type = ASR_BUMP_USER
	then call BUMP_USER_REQUEST ();
	else if request.type = ASR_ADMIN_COMMAND
	then call ADMIN_COMMAND_REQUEST ();
	else if request.type = ASR_NOTE_PNT_CHANGE
	then call NOTE_PNT_CHANGE_REQUEST ();
	else if request.type = ASR_DAEMON_COMMAND
	then call DAEMON_COMMAND_REQUEST ();
	else if request.type = ASR_COM_CHANNEL_INFO
	then call COM_CHANNEL_INFO_REQUEST ();
	else if request.type = ASR_ABS_COMMAND
	then call ABS_COMMAND_REQUEST ();
	return;
     end PROCESS_THE_MESSAGE;
     end PROCESS_MESSAGES;


/* ************************************************************************
   * DIAL_SERVER_REQUEST - For a dial request.  Presumably                *
   * dial_ctl_$dial_rq logs successful and unsuccessful requests.  No     *
   * reply is sent.  Note: request_ptr must be set so that length may be  *
   * without compiler warning.				    *
   ************************************************************************ */

DIAL_SERVER_REQUEST:
     proc ();
	request_ptr = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (dial_server_request))
	then call dial_ctl_$dial_rq (mmi.ms_ptr, addr (l_as_request_sender));
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
     end DIAL_SERVER_REQUEST;

/* ************************************************************************
   * DIAL_OUT_REQUEST - AS request for dial_out.  No reply is sent.       *
   * Note: request_ptr must be set do that length can be user without     *
   * a compiler warning.					    *
   ************************************************************************ */

DIAL_OUT_REQUEST:
     proc ();
	request_ptr = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (dial_server_request))
	then call dial_ctl_$dial_out_rq (mmi.ms_ptr, addr (l_as_request_sender));
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
     end DIAL_OUT_REQUEST;

/* ************************************************************************
   * FPE_CAUSES_LOGOUT_REQUEST -  This sets to logout the AS flag that    *
   * indicates whether a Fatal Process Error will cause a logout or a     *
   * new_proc.  The old value of the flag is returned in the reply.       *
   ************************************************************************ */

FPE_CAUSES_LOGOUT_REQUEST:
     proc ();
	l_asr_reply.data = ute.fpe_causes_logout;
	l_asr_reply.code = 0;
	ute.fpe_causes_logout = "1"b;
	call sys_log_ (SL_LOG_SILENT, "^a: ^a (^w) set fatal process error ^[logout^;new_proc^].", "as_request_sender_",
	     mmi.sender_id, mmi.sender_process_id, ute.fpe_causes_logout);
	call SEND_ASR_REPLY;
     end FPE_CAUSES_LOGOUT_REQUEST;

/* ************************************************************************
   * FPE_CAUSES_NEW_PROC_REQUEST -  This sets to new_proc the AS flag     *
   * that indicates whether a Fatal Process Error will cause a logout or  *
   * a new_proc.  The old value of the flag is returned in the reply.     *
   ************************************************************************ */

FPE_CAUSES_NEW_PROC_REQUEST:
     proc ();
	l_asr_reply.data = ute.fpe_causes_logout;
	l_asr_reply.code = 0;
	ute.fpe_causes_logout = "0"b;
	call sys_log_ (SL_LOG_SILENT, "^a: ^a (^w) set fatal process error ^[logout^;new_proc^].", "as_request_sender_",
	     mmi.sender_id, mmi.sender_process_id, ute.fpe_causes_logout);
	call SEND_ASR_REPLY;
     end FPE_CAUSES_NEW_PROC_REQUEST;

/* ************************************************************************
   * PROC_TERM_NOTIFY_REQUEST - This registers a user to be a buzzard     *
   * process, i.e., the user's process will be notified when other        *
   * processes are terminated.  Note: asr_buzzard_infop must be set so    *
   * that the length function can be used without a compiler warning.     *
   ************************************************************************ */

PROC_TERM_NOTIFY_REQUEST:
     proc ();
	asr_buzzard_infop = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (asr_buzzard_info))
	then do;
		call dpg_$register_buzzard (mmi.ms_ptr, addr (l_as_request_sender));
		unspec (l_asr_reply) = unspec (l_as_request_sender.reply_message);
		call SEND_ASR_REPLY;
	     end;
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
     end PROC_TERM_NOTIFY_REQUEST;

/* ************************************************************************
   * BUMP_USER_REQUEST - The requesting process wishes to bump another    *
   * user's process.					    *
   ************************************************************************ */

BUMP_USER_REQUEST:
     proc ();
	if mmi.ms_len >= length (unspec (asr_bump_user_info))
	then do;
		asr_bump_user_info_ptr = mmi.ms_ptr;
		call as_request_bump_user_ (asr_bump_user_info_ptr, addr (l_as_request_sender));
		unspec (l_asr_reply) = unspec (l_as_request_sender.reply_message);
		call SEND_ASR_REPLY;
	     end;
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
     end BUMP_USER_REQUEST;


ADMIN_COMMAND_REQUEST:
     proc ();
	asr_admin_command_info_ptr = mmi.ms_ptr;	/* trust as far as refer calculation */
	if mmi.ms_len >= length (unspec (asr_admin_command_info))
	then do;
		call sc_admin_command_ (asr_admin_command_info_ptr, addr (l_as_request_sender));
		unspec (l_asr_reply) = unspec (l_as_request_sender.reply_message);
		call SEND_ASR_REPLY;
	     end;
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
     end ADMIN_COMMAND_REQUEST;

NOTE_PNT_CHANGE_REQUEST:
     procedure ();

/**** This request allows the Ring-1 PNT software to notify the answering
      service of PNT changes which may require bumping currently logged
      in users, or which may require updating information in the
      user_table_entry for a user. */

	asr_note_pnt_change_info_ptr = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (asr_note_pnt_change_info))
	then call as_request_note_pnt_change_ (asr_note_pnt_change_info_ptr, addr (l_as_request_sender));
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
	return;
     end NOTE_PNT_CHANGE_REQUEST;

COM_CHANNEL_INFO_REQUEST:
     procedure ();

	asr_com_channel_info_ptr = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (asr_com_channel_info))
	then do;
		call asr_com_channel_info_srvr_ (asr_com_channel_info_ptr, addr (l_as_request_sender));
		unspec (l_asr_reply) = unspec (l_as_request_sender.reply_message);
		call SEND_ASR_REPLY ();
	     end;
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
	return;
     end COM_CHANNEL_INFO_REQUEST;

DAEMON_COMMAND_REQUEST:
     procedure ();

	asr_daemon_command_info_ptr = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (asr_daemon_command_info))
	then do;
		call asr_daemon_command_server_ (asr_daemon_command_info_ptr, addr (l_as_request_sender));
		unspec (l_asr_reply) = unspec (l_as_request_sender.reply_message);
		call SEND_ASR_REPLY ();
	     end;
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
	return;
     end DAEMON_COMMAND_REQUEST;
%page;
ABS_COMMAND_REQUEST:
     procedure ();

	asr_abs_command_info_ptr = mmi.ms_ptr;
	if mmi.ms_len >= length (unspec (asr_abs_command_info))
	then do;
		call asr_abs_command_server_ (asr_abs_command_info_ptr, addr (l_as_request_sender));
		unspec (l_asr_reply) = unspec (l_as_request_sender.reply_message);
		call SEND_ASR_REPLY ();
	     end;
	else do;
		code = error_table_$as_request_invalid_request;
		call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Message for ""^a"" (type ^d) too short from ^a.",
		     ASR_REQUEST_NAMES (request.type), request.type, mmi.sender_id);
	     end;
	return;
     end ABS_COMMAND_REQUEST;

/* ************************************************************************
   * SEND_ASR_REPLY - For those requests that send back replies, if the   *
   * reply channel is non zero, then send back the reply.		    *
   ************************************************************************ */

SEND_ASR_REPLY:
     proc ();
	if request.reply_channel ^= 0
	then do;
		unspec (fixed_bin_71_reply) = unspec (l_asr_reply);
		call hcs_$wakeup (mmi.sender_process_id, request.reply_channel, fixed_bin_71_reply, code);
	     end;
     end SEND_ASR_REPLY;

CLEANUP:
     procedure;

	if code_mask_ev_calls = 0 & code_unmask_ev_calls ^= 0
	then call ipc_$unmask_ev_calls (code_unmask_ev_calls);
						/* masked in initialize */
	call FREE_THE_MESSAGE ();

	if mmi.ms_id ^= ""b
	then call DELETE_THE_MESSAGE ();		/* delete offending message */

     end CLEANUP;

DELETE_THE_MESSAGE:
     procedure;
	call message_segment_$delete_index (ms_index, mmi.ms_id, code);
	if code ^= 0
	then call sys_log_$error_log (SL_LOG_SILENT, code, "as_request_server_", "Could not delete message ^.3b for ^a",
		mmi.ms_id, mmi.sender_id);
	else mmi.ms_id = ""b;			/* clear out since no longer valid */
	return;
     end DELETE_THE_MESSAGE;


FREE_THE_MESSAGE:
     procedure;
     
	declare msg		 bit (mmi.ms_len) aligned based (mmi.ms_ptr);

	if mmi.ms_ptr ^= null ()
	then do;
	     free msg in (user_free_area);
	     mmi.ms_ptr = null ();
	end;
	return;

     end FREE_THE_MESSAGE;

/* format: off */
%page; %include absentee_user_table;
%page; %include access_mode_values;
%page; %include acl_structures;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_request_header;
%page; %include as_requests;
%page; %include asr_abs_command;
%page; %include asr_daemon_command;
%page; %include asr_com_channel_info;
%page; %include as_request_sender_;
%page; %include as_wakeup_priorities;
%page; %include dial_server_request;
%page; %include event_call_info;
%page; %include mseg_access_mode_values;
%page; %include mseg_message_info;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   as_request_server_$init: MSG. Manipulating >sc1>as_request_.ms or IPC channels.

   S:	as (severity1)

   T:	Answering Service initialization.

   M:	MSG is an error_table_ message. A programming error has been encountered.

   A:	$contact
   After the problem is corrected, repeat the bootload operation.


   Message:
   as_request_server_$init: MSG. Deleting >sc1>as_request_.ms.

   S:	as (severity1)

   T:	Answering Service initialization.

   M:	MSG is an error_table_ message. An error was encountered while
   attempting to delete the as_request message segment, prior to re-creating
   it.  as_request_server_$init continues and attempts to create the message
   segment.

   A:	$ignore


   Message:
   as_request_server_: Request message segment not initialized or shutdown has been typed.

   S:	as (severity1)

   T:	$run

   M:	A request is being ignored because the AS request queue has not been initialized or
   the the operator has typed the shutdown command.

   A:	$ignore


   Message:
   as_request_server_: MSG. Error reading message from message segment.

   S:	as (severity0)

   T:	$run

   M:	MSG is an error_table_ message. An error occurred while reading an AS message from
   the AS request queue.

   A:	$ignore


   Message:
   as_request_server_: Message {for "REQUEST NAME" (type N)} too short from PERS.PROJ.

   S:	as (severity0)

   T:	$run

   M:	A request of type N sent by the process group id specified by PERS.PROJ was in error.
   The request is ignored.  If the request is shorter than the standard request header which 
   precedes all requests, then the request type is not present in the message.

   A:	$ignore


   Message:
   as_request_server_: MSG.  Process no longer active for request from PERS.PROJ.

   S:	as (severity0)

   T:	$run

   M:	MSG is an error_table_ message and PERS.PROJ isthe sender id.  A process sent a wakeup to the
   Answering Service but then logged out before the Answering Service handled the wakeup.

   A:	$ignore


   Message:
   as_request_server_: ERROR_MESSAGE.  Can't find message from PGID

   S:	as (severity0)

   T:	$run

   M:	MSG is an error_table_ message and PGID is a process group id.
   A process sent a wakeup to the Answering Service, but did not put a message in as_request.ms.

   A:	$ignore


   Message:
   as_request_server_: Rejected invalid type XX message from PERS.PROJ PID.

   S:	as (severity0)

   T:	$run

   M:	An invalid wakeup request has been sent to as_request_server_.
   The sending process ID is PID,
   and the sender name in the message is PERS.PROJ.
   The request is a type XX request.
   No action was taken.

   A:	$ignore


   Message:
   as_request_sender_: MSG. Could not delete message MID for PERS.PROJ.

   S:	as (severity0)

   T:	$run

   M:	MSG is an error_table_ message, MID is a message ID, PERS.PROJ is the group
   ID of the AS request sender.  The AS request message could not be deleted after executing
   the AS request.

   A:	$ignore


   Message:
   as_request_sender_: PERS.PROJ (PID) set fatal process error [logout|new_proc].

   S:	as (severity0)

   T:	$run

   M:	The process group id PERS.PROJ (process id PID) has set the AS flag which indicates
   that fatal process errors will cause a {logout|new_proc}.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end as_request_server_$init;




		    as_send_user_mail_.pl1          08/05/87  0800.0r   08/04/87  1540.6       25731



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* as_send_user_mail_ -- as utility to send mail to user */
/* format: style2,idind30 */

/**** NOTE: This does NOT validate the user's access to deliver
      mail to the destination. Clients of this should not
      set Destination to other than "" unless they are willing
      to use the AS's full access in delivering.

      Also note that this does not yet send interactive messages
      at all. Until the mail system can do without headers on
      interactive messages, this seems required. */

as_send_user_mail_:
     procedure (Caller, Destination, Group_id, Subject, Message, Access_class, Sender);

	declare (
	        Caller,				/* for error messages */
	        Destination,			/* preferred destination */
	        Group_id,				/* user name used to construct possible default destinations */
	        Subject,
	        Message,
	        Sender
	        )			        char (*);
	declare Access_class	        bit (72) aligned;
	declare code		        fixed bin (35);

	declare mlsys_utils_$send_message_to_recipient
				        entry (char (*), char (*), fixed bin, char (*), char (*),
				        bit (72) aligned, char (*) varying, fixed bin (35));

	declare sys_log_$error_log	        entry options (variable);

	declare mlsys_et_$message_delivered   fixed bin (35) ext static;
	declare mlsys_et_$message_queued      fixed bin (35) ext static;
	declare mlsys_et_$message_queued_and_delivered
				        fixed bin (35) ext static;


	if Destination ^= ""
	then do;
		call try_delivery (Destination, code);
		if code ^= 0
		then call sys_log_$error_log (SL_LOG_SILENT, code, Caller,
			"Failed to deliver mail to requested destination ^a.", Destination);
		else return;			/* all done */
	     end;

	call try_delivery (before (Group_id, "."), code); /* try for mail table */
	if code ^= 0
	then call try_delivery (substr (Group_id, 1, length (rtrim (Group_id)) - 2 /* tag */), code);
	if code ^= 0
	then call sys_log_$error_log (SL_LOG_SILENT, code, Caller, "Failed to deliver mail to user ^a.", Group_id);
	return;

try_delivery:
     procedure (addr, code);

	declare addr		        char (*);
	declare code		        fixed bin (35);

	call mlsys_utils_$send_message_to_recipient (Sender, addr, ORDINARY_DELIVERY, Subject, Message, Access_class,
	     (""), code);
	if code = mlsys_et_$message_delivered | code = mlsys_et_$message_queued
	     | code = mlsys_et_$message_queued_and_delivered
	then code = 0;
	return;
     end try_delivery;



%include mlsys_deliver_info;
%include sys_log_constants;
     end as_send_user_mail_;




		    as_send_user_message_.pl1       08/05/87  0800.0r   08/04/87  1540.6       23508



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* Entry to send an interactive message to a user from the answering
   service. */

/* format: style2,idind30 */
/**** NOTE: This does NOT validate the user's access to deliver
      mail to the destination. Clients of this should not
      set Destination to other than "" unless they are willing
      to use the AS's full access in delivering. */

/**** NOTE: This still uses send_mail_, because noone has bothered
      to make the mail system and the message facility work
      together in a reasonable way. It could use message_facility_,
      but that was not installed as of this writing. */

as_send_user_message_:
     procedure (Caller, Destination, Group_id, Message, Access_class, Sender, Express);

	declare (
	        Caller,				/* for error messages */
	        Destination,			/* preferred destination */
	        Group_id,				/* user name used to construct possible default destinations */
	        Message,
	        Sender
	        )			        char (*);
	declare Express		        bit (1) aligned;
	declare Access_class	        bit (72) aligned;
	declare code		        fixed bin (35);

	declare send_mail_$access_class       entry (character (*), character (*), pointer, bit (72) aligned,
				        fixed binary (35));

	declare sys_log_$error_log	        entry options (variable);
	declare error_table_$messages_off     fixed bin (35) ext static;

/* Destination is ignored until we can use mail_system_ */

	call try_delivery (substr (Group_id, 1, length (rtrim (Group_id)) - 2 /* tag */), code);
	if code ^= 0
	then call sys_log_$error_log (SL_LOG_SILENT, code, Caller, "Failed to deliver mail to user ^a.", Group_id);
	return;

try_delivery:
     procedure (address, code);

	declare address		        char (*);
	declare code		        fixed bin (35);

%include send_mail_info;

	send_mail_info.version = send_mail_info_version_2;
	send_mail_info.sent_from = Sender;
	send_mail_info.switches = "0"b;
	send_mail_info.switches.wakeup = "1"b;
	send_mail_info.switches.always_add = ^Express;

	call send_mail_$access_class (address, Message, addr (send_mail_info), Access_class, code);
	if code = error_table_$messages_off & ^Express
	then code = 0;
	return;
     end try_delivery;



%include mlsys_deliver_info;
%include sys_log_constants;
     end as_send_user_message_;




		    asr_com_channel_info_srvr_.pl1  07/20/88  1251.6r w 07/19/88  1536.1       56871



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(87-04-28,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle):
     Updated for change to user_table_entry.incl.pl1.
  2) change(87-07-24,Dickson), approve(87-07-24,MCR7722),
     audit(87-07-27,Brunelle):
     Added auditing of grants and failures.
                                                   END HISTORY COMMENTS */

/* format: style2,idind30 */

asr_com_channel_info_srvr_:
     procedure (ASR_info_ptr, ASR_sender_ptr);

/**** This program handles requests for info on com channels. */


/**** Written 1985-02-19, BIM */
/**** Modified 1985-02-22 by E. Swenson to not replace reply error
      code with error_table_$no_info if a more explicit error code
      has already been set up. */

	declare (ASR_info_ptr, ASR_sender_ptr)
				        pointer parameter;

	dcl     cdtx		        fixed bin;
	dcl     fnp_sw		        bit (1) aligned;
	dcl     code		        fixed bin (35);

	dcl     aim_util_$get_access_class    entry (bit (72) aligned) returns (bit (72) aligned);
	dcl     as_access_audit_$asr_com_chn_info_srvr
				        entry (char (*), pointer, pointer, fixed bin (35));
	dcl     as_user_message_$priv_add_message
				        entry (pointer, fixed bin (35));
	dcl     cdt_mgr_$find_cdt_channel     entry (pointer, character (32), fixed binary, bit (1) aligned,
				        fixed binary (35));
	dcl     ioa_$rsnnl		        entry () options (variable);
	dcl     sys_log_$error_log	        entry options (variable);

	dcl     error_table_$no_info	        fixed bin (35) ext static;

	dcl     error_table_$unimplemented_version
				        fixed bin (35) ext static;

	dcl     addr		        builtin;
	dcl     currentsize		        builtin;
	dcl     null		        builtin;
	dcl     unspec		        builtin;

	dcl     ME		        char (32) internal static options(constant)
						init ("asr_com_channel_info_srvr_");


	asr_com_channel_info_ptr = ASR_info_ptr;
	as_request_sender_ptr = ASR_sender_ptr;
	asr_reply_cci_ptr = addr (as_request_sender.reply_message);
	unspec (asr_reply_com_channel_info) = ""b;

	if asr_com_channel_info.version ^= ASR_CCI_VERSION_1
	     | asr_com_channel_info.reply_version_requested ^= AS_COM_CHANNEL_INFO_VERSION_1
	then do;
		asr_reply_com_channel_info.code = error_table_$unimplemented_version;
		go to ERROR;
	     end;

	cdtp = as_data_$cdtp;
	call cdt_mgr_$find_cdt_channel (cdtp, asr_com_channel_info.channel_name, cdtx, fnp_sw, code);
	if fnp_sw | code ^= 0
	then go to ERROR;

	cdtep = addr (cdt.cdt_entry (cdtx));

	if cdte.current_service_type = ANS_SERVICE
	then do;					/* be sure it is login channel of requestor */
		if ^(cdte.in_use = NOW_HAS_PROCESS & cdte.process -> ute.proc_id = as_request_sender.process_id)
		then go to ERROR;
	     end;
	else if cdte.current_service_type = DIAL_OUT_SERVICE | cdte.current_service_type = SLAVE_SERVICE
	     | cdte.current_service_type = TANDD_SERVICE | cdte.current_service_type = DIAL_SERVICE
	then do;
		if cdte.dialed_to_procid ^= as_request_sender.process_id
		then go to ERROR;
	     end;
	else go to ERROR;

/**** Okay, this channel belongs to this user */

	if asr_com_channel_info.reply_message_handle ^= ""b
	then call SEND_REPLY;

	call as_access_audit_$asr_com_chn_info_srvr (ME, addr(as_request_sender),
		addr(asr_com_channel_info), asr_reply_com_channel_info.code);

	return;

ERROR:
/**** If we haven't set with a more specific code, give him the generic no_info code. */
	if asr_reply_com_channel_info.code = 0
	then asr_reply_com_channel_info.code = error_table_$no_info;

	call as_access_audit_$asr_com_chn_info_srvr (ME, addr(as_request_sender),
		addr(asr_com_channel_info), asr_reply_com_channel_info.code);

	return;


SEND_REPLY:
     procedure;

	declare 1 asum_ai		        aligned like as_user_message_add_info;
	declare 1 ascci		        aligned like as_com_channel_info;
	declare code		        fixed bin (35);

	unspec (ascci) = ""b;
	ascci.version = AS_COM_CHANNEL_INFO_VERSION_1;
	ascci.channel_name = cdte.name;
	ascci.flags.access_control = cdte.flags.access_control, by name;
	ascci.attached_to_caller = "1"b;		/* always true, other case not yet supported */
	ascci.user_authenticated = (cdte.user_name.person ^= "");
	ascci.dialed_to_caller = (cdte.current_service_type = DIAL_SERVICE);
	ascci.service_type = cdte.service_type;
	ascci.current_service_type = cdte.current_service_type;
	ascci.access_class = cdte.access_class;
	ascci.current_access_class = cdte.current_access_class (1);
	if ascci.user_authenticated
	then call ioa_$rsnnl ("^a.^a", ascci.auth_user_name, (0), cdte.user_name.person, cdte.user_name.project);
	else ascci.auth_user_name = "";

	unspec (asum_ai) = ""b;
	asum_ai.version = AS_USER_MESSAGE_ADD_INFO_VERSION_1;
	asum_ai.message_ptr = addr (ascci);
	asum_ai.message_length = currentsize (ascci);
	asum_ai.message_access_class = aim_util_$get_access_class (as_request_sender.authorization);
	asum_ai.destination_info.group_id = as_request_sender.group_id;
	asum_ai.destination_info.process_id = as_request_sender.process_id;
	asum_ai.destination_info.handle = asr_com_channel_info.reply_message_handle;
	asum_ai.destination_info.ring = as_request_sender.validation_level;
	asum_ai.reader_deletes = "1"b;
	call as_user_message_$priv_add_message (addr (asum_ai), code);
	if code ^= 0
	then do;
		call sys_log_$error_log (SL_LOG, code, "asr_com_channel_info_srvr_",
		     "Failed to send reply message to ^a.", as_request_sender.group_id);
	     end;
	return;
     end SEND_REPLY;

%include as_data_;
%include as_request_header;
%include asr_com_channel_info;
%include as_com_channel_info;
%include as_request_sender_;
%include as_user_message_add;
%include cdt;
%include dialup_values;
%include author_dcl;
%include user_table_entry;
%include user_attributes;
%include sys_log_constants;

     end asr_com_channel_info_srvr_;





		    asr_daemon_command_server_.pl1  08/05/87  0800.0r   08/04/87  1540.6       91386



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30 */

asr_daemon_command_server_:
     procedure (ASR_info_ptr, ASR_sender_ptr);

/**** This program handles requests from administrators for
      commands to be sent to daemon processes via the message coordinator */

/**** Written 1985-01-14, BIM: from sc_admin_command_ */
/**** Modified 1985-03-14, E. Swenson: Removes extra NL from message 
      coordinator output. */
/**** Modified 1985-04-04, E. Swenson to send more precise reponse to 
      sender. */

	declare (ASR_info_ptr, ASR_sender_ptr)
				        pointer parameter;

	dcl     acs_mode		        bit (36) aligned;
	dcl     as_error_code	        fixed bin (35);
	dcl     code		        fixed bin (35);

	dcl     daemon_user_manager_$login_   entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     daemon_user_manager_$logout_source_no_access_check
				        entry (char (*), fixed bin (35));
	dcl     mc_wakeups_$reply_command     entry (character (*) var, pointer, fixed binary (21), pointer,
				        fixed binary (35));
	dcl     mc_check_acs_$reply	        entry (character (*), fixed binary (3), character (*), fixed binary (35));
	dcl     mc_check_acs_$log_daemon_in   entry (character (*), fixed binary (3), character (*), fixed binary (35));
	dcl     mc_check_acs_$log_daemon_out  entry (character (*), fixed binary (3), character (*), fixed binary (35));
	dcl     mc_check_acs_$quit	        entry (character (*), fixed binary (3), character (*), fixed binary (35));
	dcl     mc_commands_$reply_command    entry (character (*) var, pointer, fixed binary (21), pointer,
				        fixed binary (35));
	dcl     mc_commands_$quit_command     entry (character (*), pointer, fixed binary (35));

	dcl     sys_log_		        entry options (variable);
	dcl     sys_log_$error_log	        entry options (variable);
	dcl     up_sysctl_$check_acs	        entry (character (*), character (*), fixed binary, bit (36) aligned,
				        fixed binary (35));
	dcl     error_table_$action_not_performed
				        fixed bin (35) ext static;
	dcl     error_table_$badstar	        fixed bin (35) ext static;
	dcl     error_table_$insufficient_access
				        fixed bin (35) ext static;
	dcl     error_table_$ioname_not_found fixed bin (35) external static;
	dcl     error_table_$noentry	        fixed bin (35) external static;
	dcl     error_table_$unimplemented_version
				        fixed bin (35) ext static;
	dcl     error_table_$undefined_order_request
				        fixed bin (35) ext static;

	dcl     cleanup		        condition;


	asr_daemon_command_info_ptr = ASR_info_ptr;
	as_request_sender_ptr = ASR_sender_ptr;
	asr_reply_dc_ptr = addr (as_request_sender.reply_message);
	asr_reply_daemon_command.code = 0;
	asr_reply_daemon_command.flags = "0"b;

	if asr_daemon_command_info.version ^= ASR_DC_INFO_VERSION_1
	then do;
		asr_reply_daemon_command.code = error_table_$unimplemented_version;
		go to ERROR;
	     end;

	if asr_daemon_command_info.action_code ^= ASR_DC_LOGIN & asr_daemon_command_info.action_code ^= ASR_DC_LOGOUT
	     & asr_daemon_command_info.action_code ^= ASR_DC_QUIT & asr_daemon_command_info.action_code ^= ASR_DC_REPLY
	then do;
		asr_reply_daemon_command.code = error_table_$undefined_order_request;
		go to ERROR;
	     end;

	if asr_daemon_command_info.action_code = ASR_DC_LOGIN
	then /* user and project ignored in all other cases */
	     if asr_daemon_command_info.user_name = "*" | asr_daemon_command_info.project_name = "*"
		| asr_daemon_command_info.source_name = "*"
	     then do;
		     asr_reply_daemon_command.code = error_table_$badstar;
		     go to ERROR;
		end;

/**** Can we check an individual ACS, or must we check access to global acs */

	if ^installation_parms.validate_daemon_commands
	then do;					/* check global ACS segment */
		call up_sysctl_$check_acs ("send_daemon_command.acs", as_request_sender.group_id,
		     (as_request_sender.validation_level), acs_mode, code);
		if code ^= 0
		then do;
			call sys_log_$error_log (SL_LOG_SILENT, code, "asr_daemon_command_server_",
			     "Failed to check access for ^a to send_daemon_command.acs.",
			     as_request_sender.group_id);
			asr_reply_daemon_command.code = error_table_$insufficient_access;
			asr_reply_daemon_command.flags.command_refused = "1"b;
			go to ERROR;
		     end;
		if (acs_mode & RW_ACCESS) ^= RW_ACCESS
		then do;
			call sys_log_ (SL_LOG_SILENT,
			     "asr_daemon_command_server_: Denied daemon command for ^a in ring ^d.",
			     as_request_sender.group_id, as_request_sender.validation_level);
			asr_reply_daemon_command.code = error_table_$insufficient_access;
			asr_reply_daemon_command.flags.command_refused = "1"b;
			go to ERROR;
		     end;
	     end;
	else do;					/* We can check specific access of sender to daemon */
		if asr_daemon_command_info.action_code = ASR_DC_LOGIN
		then call mc_check_acs_$log_daemon_in (as_request_sender.group_id,
			(as_request_sender.validation_level), asr_daemon_command_info.source_name,
			asr_reply_daemon_command.code);

		else if asr_daemon_command_info.action_code = ASR_DC_LOGOUT
		then call mc_check_acs_$log_daemon_out (as_request_sender.group_id,
			(as_request_sender.validation_level), asr_daemon_command_info.source_name,
			asr_reply_daemon_command.code);


		else if asr_daemon_command_info.action_code = ASR_DC_REPLY
		then call mc_check_acs_$reply (as_request_sender.group_id, (as_request_sender.validation_level),
			asr_daemon_command_info.source_name, asr_reply_daemon_command.code);

		else if asr_daemon_command_info.action_code = ASR_DC_QUIT
		then call mc_check_acs_$quit (as_request_sender.group_id, (as_request_sender.validation_level),
			asr_daemon_command_info.source_name, asr_reply_daemon_command.code);

		if asr_reply_daemon_command.code ^= 0
		then do;
			asr_reply_daemon_command.flags.no_access_to_daemon = "1"b;
			go to ERROR;
		     end;
	     end;

/**** Okay, the sucker is authorized. Now log the command line. */

	call sys_log_ (SL_LOG,
	     "asr_daemon_command_server_: ^a: ^[LOGIN^;LOGOUT^;QUIT^;REPLY^]^[ ^a.^a^;^s^s^] ^a ^[^a^]",
	     as_request_sender.group_id, asr_daemon_command_info.action_code,
	     asr_daemon_command_info.action_code = ASR_DC_LOGIN, asr_daemon_command_info.user_name,
	     asr_daemon_command_info.project_name, asr_daemon_command_info.source_name,
	     (asr_daemon_command_info.action_code = ASR_DC_LOGIN | asr_daemon_command_info.action_code = ASR_DC_REPLY),
	     rtrim (asr_daemon_command_info.command, byte (10)));

/**** Now, do what the person asked */

	if asr_daemon_command_info.action_code = ASR_DC_LOGIN
	then do;
		call daemon_user_manager_$login_ (asr_daemon_command_info.user_name,
		     asr_daemon_command_info.project_name, asr_daemon_command_info.source_name,
		     asr_daemon_command_info.command, as_error_code);

/**** The following is really low-class.  daemon_user_manager_$login_ returns
      as error table codes which the user will not be able to convert.  Thus
      we convert it for him...in a less-than-optimal way.  A better solution
      would be, perhaps, to use regular error_table_ codes in the AS. */

		if as_error_code ^= 0
		then asr_reply_daemon_command.code = error_table_$action_not_performed;
		else asr_reply_daemon_command.code = 0;
	     end;
	else if asr_daemon_command_info.action_code = ASR_DC_LOGOUT
	then do;
		call daemon_user_manager_$logout_source_no_access_check (asr_daemon_command_info.source_name,
		     asr_reply_daemon_command.code);
		if asr_reply_daemon_command.code = error_table_$noentry
		then asr_reply_daemon_command.no_such_daemon = "1"b;
	     end;
	else if asr_daemon_command_info.action_code = ASR_DC_QUIT
	then do;
		call mc_commands_$quit_command (asr_daemon_command_info.source_name, null (),
		     asr_reply_daemon_command.code);
		if asr_reply_daemon_command.code = error_table_$ioname_not_found
		then asr_reply_daemon_command.no_such_daemon = "1"b;
	     end;
	else if asr_daemon_command_info.action_code = ASR_DC_REPLY
	then do;
		call mc_commands_$reply_command ((asr_daemon_command_info.source_name),
		     addr (asr_daemon_command_info.command), length (asr_daemon_command_info.command), null (),
		     asr_reply_daemon_command.code);
		if asr_reply_daemon_command.code = error_table_$ioname_not_found
		then asr_reply_daemon_command.no_such_daemon = "1"b;
	     end;

ERROR:
	return;


%include as_data_;
%include sys_log_constants;
%include access_mode_values;
%include as_request_header;
%include asr_daemon_command;
%include as_request_sender_;
%include installation_parms;
	declare ip		        pointer defined (as_data_$rs_ptrs (0));

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   asr_daemon_command_server_: PERSON: COMMAND INFO

   S:     $sc

   T:	$run

   M:	A system administrator has sent a for a daemon to the
   Initializer, which executes it.

   A:	$ignore


   Message:
   asr_daemon_command_server_: Failed to check access for USER.

   S:     $sc

   T:	$run

   M:	User USER requested the system to execute a daemon command,
   but validate_daemon_commands was not enabled and 
   the system could not determine their access to the send_daemon_command
   acs.

   A:	$ignore


   Message:
   asr_daemon_command_server_: Denied send_daemon_command for USER in ring RING.

   S:     $sc    

   T:	$run

   M:	User USER requested the system to execute a daemon command,
   but lacked access to >sc1>admin_acs>send_admin_command.acs or the appropriate
   daemon source ACS.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end asr_daemon_command_server_;





		    cdt_mgr_.pl1                    07/20/88  1251.6r w 07/19/88  1536.1      229383



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

/* cdt_mgr_.pl1 -- entries to manage cdt with tree of channel names */
/* format: style2 */

cdt_mgr_:
     procedure;					/** This entry is not retained */

/* Initial Coding -- Benson I. Margulies December 1981 */
/* Fix to change daughter ptr when new entry added to head of daughter list
	BIM 7/82 */
/* Modified 1984-08-27 BIM for login auth ranges, com channel AIM. */


/****^  HISTORY COMMENTS:
  1) change(87-06-08,Beattie), approve(87-04-06,MCR7656),
     audit(87-07-14,Parisek), install(87-08-04,MR12.1-1055):
     Initialize variables used to control use of IOCBs.
                                                   END HISTORY COMMENTS */


	declare ix		 fixed bin;
	declare code		 fixed bin (35);
	declare (fnpx, cdtx)	 fixed bin;
	declare first_cdtep		 pointer;
	declare first_cdte_offset	 fixed bin (18) unsigned;
	declare name_offset		 fixed bin (18) unsigned;
	declare cdte_size		 fixed bin (18) unsigned;
	declare thread_order	 (2711) fixed bin unaligned;
						/* max possible needed */


	declare parse_fnp_name_	 entry (char (*), fixed bin);
	declare sort_items_$char	 entry (ptr, fixed bin (24));

	declare error_table_$badcall	 fixed bin (35) ext static;
	declare error_table_$unimplemented_version
				 fixed bin (35) ext static;
	declare error_table_$namedup	 fixed bin (35) ext static;
	declare error_table_$noentry	 fixed bin (35) ext static;
	declare as_error_table_$cdte_in_use_wrong
				 fixed bin (35) ext static;
	declare as_error_table_$illegal_top_mpx_name
				 fixed bin (35) ext static;
	declare as_error_table_$salvage_cdt
				 fixed bin (35) ext static;

	declare (addr, addrel, after, before, bin, currentsize, divide, index, length, null, rel, reverse,
	        rtrim, substr, unspec) builtin;

%page;
/* cdt_mgr_$thread: process an entire cdt, threading cdt entries. */
/* CDT_pointer is a pointer to the cdt segment. */


/* This program calls sub_err_ with an info structure for errors */
/* to permit more explicit disgnosis. Callers should handle */
/* the sub_error_ condition with a callername of "cdt_mgr_" */
/* to avoid spurious command levels. */

thread:
     entry (CDT_pointer, Code);


	declare (
	        CDT_pointer		 pointer,
	        Code		 fixed bin (35)
	        )			 parameter;

	cdtp = CDT_pointer;
	Code = 0;

	if cdt.version < CDT_version
	then do;
		call signal_error (error_table_$unimplemented_version, "CDT version is ^d, must be ^d", cdt.version,
		     CDT_version);
		Code = error_table_$unimplemented_version;
		go to RETURN;
	     end;

/**** first init the fnpes */
/**** since fnpe's are not in the array of cdtes, they cannot be threaded */
/**** as siblings. */
/**** the -2 in fnpe.threads.next_sister is used to identify fnpes */


	do fnpx = 1 to 8;
	     fnpep = addr (cdt.fnp_entry (fnpx));
	     fnpe.next_sister = -2;			/* invalid -- identifies fnpe */
	     fnpe.prev_sister = -2;
	     fnpe.mother = 0;			/* top of tree */
	     fnpe.daughter = 0;			/* null for now */
	     fnpe.daughter_count = 0;
	end;

/**** Now look at each cdte and thread it in. If some parent does not */
/**** exist, then the channel is remembered for postprocessing */
/**** cdt.n_cdtes may be wrong, due to threading lossage, since it is */
/**** maintained along with threads. If it is, the code fixes it and */
/**** retries.  */

/**** cdt.current_size might be wrong as well, so we check for putative */
/**** cdte's for the entire length of the cdt. This depends on the fact */
/**** that unused cdte's past the end contain NOW_FREE. */

/**** note that much of this checking is not needed for the cv_cmf case, */
/**** but there is no time now (10.0) to make a salvage vs. nonsalvage */
/**** distinction. */


/**** Find the last nonzero anything in the segment. */

	declare cdt_cur_length	 fixed bin;

	begin;
	     declare 1 SB		      aligned like status_branch;
	     declare d		      char (168);
	     declare e		      char (32);
	     declare sys_info$max_seg_size  fixed bin (35) ext static;

	     unspec (SB) = ""b;
	     call hcs_$fs_get_path_name (cdtp, d, (0), e, (0));
	     call hcs_$status_long (d, e, 1 /* chase */, addr (SB), null (), (0));
	     if SB.current_length > 0
	     then cdt_cur_length = SB.current_length * 1024;
						/* its in records */
	     else cdt_cur_length = sys_info$max_seg_size; /* its in words */
	end;

	begin;
	     declare cdt_as_chars	      char (4 * cdt_cur_length) unaligned based (cdtp);
						/* chars because bit string ops not optimized by compiler */
	     declare first_non_nullx	      fixed bin (21);
	     declare first_non_null	      fixed bin (18) unsigned;
	     declare (length, low, reverse, verify)
				      builtin;
	     declare add_char_offset_	      entry (ptr, fixed bin (21)) returns (ptr) reducible;

	     first_non_nullx = verify (reverse (cdt_as_chars), low (1));
						/* This is exceedingly unlikely to be nonzero, but ... */

	     first_non_nullx = length (cdt_as_chars) - first_non_nullx;
						/* ASSUME that it will not be zero !? */

	     first_non_null = bin (rel (add_char_offset_ (cdtp, first_non_nullx)), 18);
	     if first_non_null < bin (rel (addr (cdt.cdt_entry (1))), 18)
	     then go to EMPTY_CDT;			/* hmmm */

	     do ix = 1 repeat 1 + ix;
		if bin (rel (addr (cdt.cdt_entry (ix))), 18) ^< first_non_null
		then go to FOUND_LAST_CDTE;
	     end;

FOUND_LAST_CDTE:
	     cdt.current_size = ix;
	end;					/* the block that finds currentsize */


RETRY_CDT_NAME_SORT:
	begin;
	     declare last_in_use_cdtx	      fixed bin;
	     declare 1 sort_info	      aligned,
		     2 n_cdtes	      fixed bin (24) init (cdt.n_cdtes),
		     2 cdte_name_ptrs     (cdt.n_cdtes) pointer unaligned;

	     ix = 0;

	     do cdtx = 1 to cdt.current_size;
		cdtep = addr (cdt.cdt_entry (cdtx));
		if cdte.in_use ^= NOW_FREE
		then do;
			last_in_use_cdtx = cdtx;	/* might be smaller than the value calculated above */
			ix = ix + 1;
			sort_info.cdte_name_ptrs (ix) = addr (cdte.name);
		     end;
		else unspec (cdte.threads) = ""b;
	     end;

	     cdt.current_size = last_in_use_cdtx;	/* correct silently */

	     if ix ^= cdt.n_cdtes
	     then do;
		     call signal_warning (as_error_table_$cdte_in_use_wrong,
			"There were ^d non-free channels within the current CDT size (^d), but cdt.n_cdtes was ^d.",
			ix, cdt.current_size, cdt.n_cdtes);
		     cdt.n_cdtes = ix;
		     go to RETRY_CDT_NAME_SORT;
		end;

	     call sort_items_$char (addr (sort_info), 32);

	     first_cdtep = addr (cdt.cdt_entry (1));
	     first_cdte_offset = bin (rel (first_cdtep));
	     name_offset = bin (rel (addr (first_cdtep -> cdte.name))) - first_cdte_offset;
	     cdte_size = currentsize (cdte);

	     do ix = 1 to cdt.n_cdtes;		/* now turn the array of pointers to names */
						/* into an array of cdtx's. This is a bit messy */

/**** Given a cdtep derived from the name ptr, we can get the relative */
/**** offset from the first cdte, and divide by cdte size for an index. */
/**** the first cdte will come out as 0, so we add one. */

		cdtep = addrel (sort_info.cdte_name_ptrs (ix), -name_offset);
		thread_order (ix) = divide (bin (rel (cdtep)) - first_cdte_offset, cdte_size, 18, 0) + 1;
	     end;
	end;					/* Free up the array of pointers */

/**** Now we have a vector of cdtx's that represents the sort order */
/**** of the cdte names. so we can thread each one in trivially. */
/**** Since threading from scratch is not a time-critical operation, */
/**** it is done by calling the thread_in_cdte procedure once for each */

	do ix = 1 to cdt.current_size;		/* wipe old threads */
	     unspec (cdt.cdt_entry (ix).threads) = ""b;
	end;
	unspec (cdt.threads) = ""b;

	do ix = 1 to cdt.n_cdtes;
	     call thread_in_cdte ((thread_order (ix)));	/* unaligned to aligned across this call */
	end;

/* This should be a threaded cdt. */

EMPTY_CDT:
	return;
%page;

thread_in_cdte:
     procedure (cdtx);

	declare cdtx		 fixed bin;
	declare parent_name		 character (32);
	declare parentx		 fixed bin;	/* cdt or fnpx */
	declare sisx		 fixed bin;
	declare l_cdtep		 pointer;
	declare 1 lcdte		 aligned like cdte based (l_cdtep);
	declare p_cdtep		 pointer;
	declare 1 pcdte		 aligned like cdte based (p_cdtep);
	declare 1 lthreads		 aligned like channel_threads based (threads_ptr);
	declare threads_ptr		 pointer;
	declare fnpe_sw		 bit (1) aligned;

	l_cdtep = addr (cdt.cdt_entry (cdtx));

	parent_name = reverse (after (reverse (lcdte.name), "."));
	if parent_name = ""
	then parent_name = lcdte.name;

	if parent_name = lcdte.name			/* is it top level? */
	then do;					/* check for conflict with fnp names and handle
	            top level threads */

/**** inside this block, parent_XXX are really current_XXX */


		call parse_fnp_name_ (parent_name, fnpx);

		if fnpx > 0			/* Legal FNP */
		then do;
			call signal_error (as_error_table_$illegal_top_mpx_name,
			     "Non-FNP channel ^a has name reserved for FNP's.", parent_name);
			Code = as_error_table_$illegal_top_mpx_name;
			go to RETURN;
		     end;

/**** valid top level mpx name. Thread into top level chain */

		lcdte.threads.mother = 0;		/* top of tree */
		lcdte.threads.daughter, lcdte.threads.daughter_count = 0;

		if cdt.threads.daughter = 0		/* first nonfnp top mpx */
		then do;
			cdt.threads.daughter = cdtx;
			cdt.threads.daughter_count = 1;
			lcdte.threads.prev_sister, lcdte.threads.next_sister = 0;
						/* cleaner */
		     end;

		else do;
			do parentx = cdt.threads.daughter repeat (cdt.cdt_entry (parentx).next_sister)
			     while (cdt.cdt_entry (parentx).next_sister ^= 0
			     & parent_name > cdt.cdt_entry (parentx).name);
			end;			/* stop on end-of-the-line or < */


/* p_cdtep points to ELDER SISTER OR YOUNGER SISTER ! */

			p_cdtep = addr (cdt.cdt_entry (parentx));

			if parent_name < pcdte.name
			then do;			/* goes in before */
				lcdte.prev_sister = pcdte.prev_sister;
				pcdte.prev_sister = cdtx;
				lcdte.next_sister = parentx;
				cdt.threads.daughter_count = cdt.threads.daughter_count + 1;
			     end;

			else if parent_name > pcdte.name
						/* end of chain */
			then do;
				pcdte.next_sister = cdtx;
						/* was 0 */
				lcdte.prev_sister = parentx;
				lcdte.next_sister = 0;
				cdt.threads.daughter_count = cdt.threads.daughter_count + 1;
			     end;

			else do;			/* OOPS */
				call signal_error (error_table_$namedup,
				     "Channel ^a already in cdt. newx = ^d, oldx = ^d.", lcdte.name, cdtx,
				     parentx);

/***** Return here is a request to fix it, because its the live cdt. */

				call signal_warning (0, "Deleting second copy of ^a (at ^d).", lcdte.name, cdtx);
				lcdte.in_use = NOW_FREE;
			     end;
		     end;
	     end;					/* top level mpx case */

	else do;					/* non-top-level */
		call find_channel (parent_name, parentx, fnpe_sw, code);
						/* fnpe_sw is "1"b if parent is a FNP */

		if code ^= 0
		then do;
			call signal_error (code, "Channel ^a: parent channel ^a not in cdt.", lcdte.name,
			     parent_name);

/***** return here indicates that it was the service CDT that was busted, *****/
/***** and repairs should be attempted */
			call signal_warning (0, "Deleting orphan channel ^a (^d).", lcdte.name, cdtx);
			lcdte.in_use = NOW_FREE;
		     end;

		if fnpe_sw
		then threads_ptr = addr (cdt.fnp_entry (-parentx).threads);
		else threads_ptr = addr (cdt.cdt_entry (parentx).threads);

		lcdte.daughter, lcdte.daughter_count = 0;
		lcdte.mother = parentx;
		if lthreads.daughter = 0		/* first daughter */
		then do;
			lthreads.daughter = cdtx;
			lthreads.daughter_count = 1;
			lcdte.next_sister, lcdte.prev_sister = 0;
		     end;
		else do;

			do sisx = lthreads.daughter	/** **/
			     repeat (cdt.cdt_entry (sisx).next_sister)
						/** **/
			     while (cdt.cdt_entry (sisx).next_sister ^= 0
						/** **/
			     & lcdte.name > cdt.cdt_entry (sisx).name);
			end;			/* stop on end-of-the-line or < */

			p_cdtep = addr (cdt.cdt_entry (sisx));
						/* pcdte is ELDER OR YOUNGER SISTER */

			if lcdte.name < pcdte.name
			then do;			/* before */
				lcdte.prev_sister = pcdte.prev_sister;
				pcdte.prev_sister = cdtx;
				lcdte.next_sister = sisx;
				if lcdte.prev_sister > 0
				then cdt.cdt_entry (lcdte.prev_sister).next_sister = cdtx;
				else lthreads.daughter = cdtx;
						/* This is now head of chain */
				lthreads.daughter_count = lthreads.daughter_count + 1;
			     end;
			else if lcdte.name > pcdte.name
			then do;
				lcdte.prev_sister = sisx;
				lcdte.next_sister = 0;
				pcdte.next_sister = cdtx;
				lthreads.daughter_count = lthreads.daughter_count + 1;
			     end;
			else do;
				call signal_error (error_table_$namedup,
				     "Channel ^a already in CDT. newx = ^d, oldx = ^d.", lcdte.name, cdtx, sisx);
				call signal_warning (0, "Deleting duplicate channel ^a (^d).", lcdte.name, cdtx);
				lcdte.in_use = NOW_FREE;
			     end;
		     end;				/* nontrivial chain */
	     end;					/* non-top-level */

     end thread_in_cdte;				/* thats all for that */
%page;

find_channel:
     procedure (name, idx, fnpe_sw, code);

	declare name		 character (32);
	declare target_name		 character (32);
	declare idx		 fixed bin;
	declare fnpe_sw		 bit (1) aligned;
	declare code		 fixed bin (35);

	declare correct_level	 bit (1) aligned;
	declare new_compare_length	 fixed bin;
	declare x			 fixed bin;
	declare compare_length	 fixed bin (21);
	declare ltp		 pointer;
	declare start_threads_ptr	 pointer;
	declare daughters_seen	 fixed bin;
	declare total_channels_seen	 fixed bin;
	declare first_name		 character (32) aligned;

/**** we call signal_error for inconsistencies, return code for channel-not-found */
/**** this entrypoint always starts at the top. find_channel_start is called */


	target_name = name;

/**** with a cdtx or fnpx to start at. It enters further down, after the top level */
/**** stuff. */

/**** we establish the search start point by checking for the FNP case. */
/**** it is too painful to make the efficient searcher deal with that. */

	code = 0;
	first_name = before (target_name, ".");

	call parse_fnp_name_ ((first_name), fnpx);

	if fnpx > 0
	then do;					/* forsure */
		if first_name = target_name		/* thats all they wanted */
		then do;
			idx = -fnpx;
			fnpe_sw = "1"b;
			return;
		     end;
		start_threads_ptr = addr (cdt.fnp_entry (fnpx).threads);
		compare_length = index (substr (target_name, 3), ".");
		if compare_length = 0
		then do;
			compare_length = length (rtrim (target_name));
			correct_level = "1"b;
		     end;
		else do;
			compare_length = compare_length + 1;
						/* dont look for trailing . */
			correct_level = "0"b;
		     end;
	     end;
	else do;
		start_threads_ptr = addr (cdt.threads); /* start with toplevel chain */
		compare_length = index (target_name, ".");
		if compare_length = 0
		then do;
			correct_level = "1"b;	/* looking at this level for final answer */
			compare_length = length (rtrim (target_name));
		     end;
		else do;
			compare_length = compare_length - 1;
						/* channels cant end in . */
			correct_level = "0"b;
		     end;
	     end;
	fnpe_sw = "0"b;				/* guaranteed */

	ltp = start_threads_ptr;
	total_channels_seen = 0;

/**** ltp must be a pointer to a thread block for the parent */
/**** of the next list to examine when control gets here */

RECURSE_DOWN:
	begin;
	     declare search_name	      character (compare_length) defined (target_name) position (1);
	     daughters_seen = 0;

	     if ltp -> channel_threads.daughter = 0	/* no more */
	     then do;
		     code = error_table_$noentry;
		     return;
		end;

	     do x = ltp -> channel_threads.daughter	/** **/
		repeat (cdt.cdt_entry (x).threads.next_sister)
						/** **/
		while (x ^= 0);

		daughters_seen = daughters_seen + 1;
		total_channels_seen = total_channels_seen + 1;
		if daughters_seen > ltp -> channel_threads.daughter_count
		then do;
			call signal_error (as_error_table_$salvage_cdt, "Too many daughters for cdtx = ^d.",
			     cdt.cdt_entry (x).threads.mother);
			go to RETURN;		/* Force a return */
		     end;
		if total_channels_seen > cdt.n_cdtes
		then do;
			call signal_error (as_error_table_$salvage_cdt, "Too many channels found via threads");
			go to RETURN;
		     end;

		if cdt.cdt_entry (x).name = search_name
		then do;				/* matches so far */
			if correct_level		/* as far as it has to */
			then do;
				if cdt.cdt_entry (x).in_use = NOW_FREE
				then call signal_error (as_error_table_$salvage_cdt,
					"cdt entry found, but in_use is NOW_FREE.");
				idx = x;
				return;		/* found */
			     end;
			new_compare_length = index (substr (target_name, compare_length + 2), ".");
			if new_compare_length = 0
			then do;
				correct_level = "1"b;
				compare_length = length (rtrim (target_name));
			     end;
			else compare_length = compare_length + new_compare_length;
			ltp = addr (cdt.cdt_entry (x).threads);
			go to RECURSE_DOWN;		/* out and into block */
		     end;
		else if cdt.cdt_entry (x).name > search_name /* cant possibly match */
		     | cdt.cdt_entry (x).threads.next_sister = 0
						/* noplace else to look */
		then do;
			code = error_table_$noentry;
			if cdt.cdt_entry (x).threads.next_sister = 0
			     & daughters_seen ^= ltp -> channel_threads.daughter_count
			then do;
				call signal_error (as_error_table_$salvage_cdt, "Missing daughters for cdtx ^d.",
				     cdt.cdt_entry (x).threads.mother);
				go to RETURN;
			     end;
			return;
		     end;
	     end;					/* the do loop */
	end RECURSE_DOWN;
     end find_channel;

%page;

signal_error:
     procedure options (variable);

	declare alp		 pointer;
	declare cu_$arg_list_ptr	 entry (ptr);
	declare code_ptr		 pointer;
	declare code		 fixed bin (35) based (code_ptr);
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare ioa_$general_rs	 entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
				 bit (1) aligned);

	declare sub_err_		 entry () options (variable);
	declare errormsg		 character (168);
	declare flag		 character (1);
	declare warning		 bit (1) aligned;

	warning = "0"b;
	go to COMMON;
signal_warning:
     entry options (variable);
	warning = "1"b;

COMMON:
	call cu_$arg_list_ptr (alp);

	call cu_$arg_ptr (1, code_ptr, (0), (0));
	call ioa_$general_rs (alp, 2, 3, errormsg, (0), "1"b, "0"b);
	if warning
	then flag = "c";
	else flag = "h";
	call sub_err_ (code, "cdt_mgr_", flag, cdtp, (0), "^a", errormsg);
     end signal_error;

%page;

find_cdt_channel:
     entry (CDT_pointer, Channel_name, Channel_idx, FNP_sw, Code);
	declare (
	        Channel_name	 character (32),
	        Channel_idx		 fixed bin,
	        FNP_sw		 bit (1) aligned
	        )			 parameter;

	cdtp = CDT_pointer;
	call find_channel (Channel_name, Channel_idx, FNP_sw, Code);

RETURN:
	return;

thread_in_cdt_channel:
     entry (CDT_pointer, Channel_idx);
	cdtp = CDT_pointer;
	call thread_in_cdte (Channel_idx);
	cdt.n_cdtes = cdt.n_cdtes + 1;
	return;

thread_out_cdt_channel:
     entry (CDT_pointer, Channel_idx);

	cdtp = CDT_pointer;

	call thread_out_cdte (Channel_idx);
	cdt.n_cdtes = cdt.n_cdtes - 1;
	if Channel_idx = cdt.current_size
	then cdt.current_size = cdt.current_size - 1;
	return;

thread_out_cdte:
     procedure (cdtx);
	declare cdtx		 fixed bin;

	if cdtx < 0
	then call signal_error (error_table_$badcall, "thread_out of a FNP. fnpx = ^d.", -cdtx);

	cdtep = addr (cdt.cdt_entry (cdtx));
	if cdte.threads.prev_sister ^= 0		/* not first in chain */
	then do;
		cdt.cdt_entry (cdte.threads.prev_sister).next_sister = cdte.threads.next_sister;
		if cdte.threads.next_sister ^= 0
		then cdt.cdt_entry (cdte.threads.next_sister).threads.prev_sister = cdte.threads.prev_sister;
	     end;
	else do;					/* head of chain or singleton */
		if cdte.threads.next_sister ^= 0
		then cdt.cdt_entry (cdte.threads.next_sister).prev_sister = 0;
		if cdte.threads.mother < 0		/* FNP */
		then cdt.fnp_entry (-cdte.threads.mother).daughter = cdte.threads.next_sister;
		else if cdte.threads.mother > 0	/* random chn */
		then cdt.cdt_entry (cdte.threads.mother).daughter = cdte.threads.next_sister;
		else if cdte.threads.mother = 0	/* toplevel */
		then cdt.threads.daughter = cdte.threads.next_sister;
	     end;

/**** now to fix mother ****/

	if cdte.threads.mother < 0
	then cdt.fnp_entry (-cdte.threads.mother).daughter_count =
		cdt.fnp_entry (-cdte.threads.mother).daughter_count - 1;
	else if cdte.threads.mother > 0
	then cdt.cdt_entry (cdte.threads.mother).daughter_count =
		cdt.cdt_entry (cdte.threads.mother).daughter_count - 1;
	else cdt.threads.daughter_count = cdt.threads.daughter_count - 1;
     end thread_out_cdte;


%page;
init:
     entry (System_dir, CDT_pointer, Code);

	declare System_dir		 character (*);
	declare CDT		 char (3) init ("cdt") internal static options (constant);

/* initiate the CDT, note that it is initiated, check for damage,
   rethread if there is and caller restarts error. */

/* if it were not for the damn initializer segfault special case, */
/* we could just have a seg_fault_error handler. No */
/* such luck. However, we establish the handler, so that the */
/* change when the faults come back will be small */


	declare initiate_file_	 entry (character (*), character (*), bit (*), pointer, fixed binary (24),
				 fixed binary (35));
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));
	declare hcs_$force_write	 entry (ptr, bit (36), fixed bin (35));
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));

	declare seg_fault_error	 condition;
	declare error_table_$seg_busted
				 fixed bin (35) ext static;
	declare as_error_table_$cdt_not_shut_down
				 ext static fixed bin (35);

/* The goal here it to detect inconsistent cdt's without having */
/* to track around checking for inconsistencies. The claim is that */
/* the only way a cdt can get inconsistent is by a crash during installation. */
/* The only way we could detect that, though, is by force_writing some */
/* indication that something was happening whenever an installation was */
/* done. The only existing force_write primitive writes all modified pages, */
/* so the performance penalty would be excessive. Instead, we just detect */
/* any crash in between AS startup and shutdown. In that case, we signal */
/* the need for a salvage. Since a salvage is not that expensive, and */
/* crashes are (cross fingers) fairly rare, this seems appropriate. */
/* the salvaging is not done here. The caller of this entry is expected */
/* to have a sub_error_ handler in which the codes error_table_$seg_busted */
/* and as_error_table_$cdt_not_shut_down are detected. The caller might elect */
/* to give system operations the oportunity to install a cdt instead */
/* of just salvaging this one. */

	cdtp, CDT_pointer = null ();
	Code = 0;

	call initiate_file_ (System_dir, CDT, RW_ACCESS, cdtp, (0), code);

	if code = error_table_$noentry
	then do;
		Code = code;			/* expected possibility */
		return;
	     end;

	if cdtp = null
	then do;
		call signal_error (code, "Could not initiate ^a>^a.", System_dir, CDT);
		Code = code;
		return;
	     end;

	on seg_fault_error
	     begin;
		call signal_error (error_table_$seg_busted, "Damage switch set on ^a>^a.", System_dir, CDT);
/**** if we get here, we are to continue */

	     end;

	if cdt.cdt_is_live
	then do;
		code = as_error_table_$cdt_not_shut_down;
		call signal_error (code, "^a>^a was not shut down in last session.", System_dir, CDT);

/**** if we are returned to, we are to continue. If salvaging was to ****/
/**** be done, caller has done it ****/
	     end;

	cdt.cdt_is_live = "1"b;

	cdt.cdt_entry.iocbp (*) = null ();		/* these must start out null for each bootload */
	cdt.cdt_entry.use_iocb (*) = "0"b;

	call hcs_$force_write (cdtp, (36)"0"b, (0));	/* do the best we can */

/* for now, this will cause mux-mgr to call the thread entrypoint and then */
/* return to us. the reason for this somewhat convoluted approach is */
/* that someday it may be desirable to allow system operations to intervene */
/* before these auto-salvages, perhaps to install a different cdt. */

	if cdt.version ^= CDT_version
	then call signal_error (error_table_$unimplemented_version, "CDT version is ^d, should be ^d.", cdt.version,
		CDT_version);

	CDT_pointer = cdtp;
	Code = 0;
	return;


shut:
     entry (CDT_pointer);				/* orderly shutdown */


	cdtp = CDT_pointer;
	cdt.cdt_is_live = "0"b;
	call terminate_file_ (cdtp, (0), TERM_FILE_TERM | TERM_FILE_FORCE_WRITE, (0));
	CDT_pointer, cdtp = null;
	return;

%page;
%include author_dcl;
%include cdt;
%include dialup_values;
%include access_mode_values;
%include status_structures;
%include terminate_file;
     end cdt_mgr_;




		    connection_list_manager_.pl1    03/15/89  0842.4r w 03/15/89  0800.0      421902



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-05-01,Coren), approve(87-07-08,MCR7681), audit(87-03-26,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-07,GDixon), approve(87-07-08,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations.
      B) Correct cleanup strategy.
      C) Correct storing of service type in active_connection.service_type.
      D) Thread entry back to owner when $priv_remove_user is called to
         remove the connection from the user.
      E) Remove $delete_name and $delete_offset entrypoints, which aren't
         called by any gate and don't fit into the gate strategy.
      F) Change $init to ignore all but the first call during a given
         bootload.
      G) Remove references to connection_manager_data_.
      H) Add force_accounting_flush_entry parameter to $add entrypoint.  Return
         this entry in the active_connection_info structure.
  3) change(87-04-28,Brunelle), approve(87-07-08,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
     Corrected Thread_user to correctly thread next_act_ptr entry back to this
     entry.
  4) change(87-05-06,GDixon), approve(87-07-08,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Map error_table_$lock_wait_time_exceeded into
         error_table_$already_initialized.
      B) Use sys_info$system_control_dir to locate active_connection_list.
  5) change(87-05-13,Brunelle), approve(87-07-08,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
     Add .owner_group_id field to structure and change code to use it.  Added
     check for the connection list not being initialized yet.  Pass back new
  6) change(87-06-22,GDixon), approve(87-07-08,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Add back the delete_offset entrypoint.
  7) change(87-07-21,GDixon), approve(87-07-21,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Sort parameter declarations.
      B) Correct comments.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */

connection_list_manager_:
     procedure ();
	return;					/* main entry is never called */

/* This procedure contains a collection of entry points for managing the
   system-wide list of active network connections.  This list is used, for
   example, by the Answering Service when a user process terminates in order
   to clean up any connections that were assigned to the process.

   There is an entry for each established connection.  Each one has
   associated with it an "owner" process (frequently a login server) and a
   "user" process.

   The table is maintained in ring 1, since it is potentially accessible by
   all processes.

   Entries in this procedure are called through one of three gates:

   connection_list_:       process must be owner and user of connection
   priv_connection_list_:  process must be owner, but need not be user
   hpriv_connection_list_: process may manipulate connections of which it is
   neither owner nor user

   Further, some of the entries may be called by inner-ring network-management
   programs.
*/

/* NOTE: Someday there should be some code added to check that the list is
   consistent, and take some appropriate action if it isn't. */

/* DECLARATIONS */

/* PARAMETERS */

dcl  a_code fixed bin (35) parameter;
dcl  a_connection_handle fixed bin (35) parameter;
dcl  a_connection_info_ptr pointer parameter;
dcl  a_connection_name char (*) parameter;
dcl  a_force_accounting char (*) parameter;
dcl  a_force_disconnect char (*) parameter;
dcl  a_handle bit (72) aligned parameter;
dcl  a_offset bit (18) parameter;
dcl  a_owner_process_id bit (36) parameter;
dcl  a_service_type char (*) parameter;
dcl  a_terminate_event_channel fixed bin (71) parameter;
dcl  a_usage_type fixed bin parameter;
dcl  a_user_group_id char (*) parameter;
dcl  a_user_process_id bit (36) parameter;


/* AUTOMATIC */

dcl  act_dir_name char (168);
dcl  code fixed bin (35);
dcl  connection_handle fixed bin (35);
dcl  connection_name char (32);
dcl  force_acct_entry char (64);
dcl  force_disc_entry char (64);
dcl  hash_index fixed bin;
dcl  hash_size fixed bin;
dcl  hpriv_entry bit (1);
dcl  initializer_handle bit (72) aligned;
dcl  locked bit (1);
dcl  my_process_id bit (36);
dcl  name_entry bit (1);
dcl  next_act_ptr pointer;
dcl  next_offset bit (18);
dcl  offset bit (18);
dcl  orig_level fixed bin;
dcl  owner_process_id bit (36);
dcl  priv_entry bit (1);
dcl  service_type char (32);
dcl  sys_high_auth bit (72) aligned;
dcl  temp_lock_word bit (36) aligned;
dcl  term_event_channel fixed bin (71);
dcl  this_act_ptr pointer;
dcl  this_ring fixed bin;
dcl  usage_type fixed bin;
dcl  user_group_id char (32);
dcl  user_process_id bit (36);
dcl  words_used fixed bin;


/* AUTOMATIC STRUCTURES */

dcl  1 auto_area_info aligned like area_info;
dcl  1 auto_create_branch_info aligned like create_branch_info;


/* ENTRIES */

dcl  convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  cu_$level_get entry (fixed bin);
dcl  cu_$level_set entry (fixed bin);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  get_group_id_ entry () returns (char (32));
dcl  get_process_id_ entry () returns (bit (36));
dcl  get_ring_ entry () returns (fixed bin (3));
dcl  hash_index_ entry (pointer, fixed bin (21), fixed bin, fixed bin) returns (fixed bin);
dcl  hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));


/* EXTERNAL STATIC */

dcl  (
     error_table_$already_initialized,
     error_table_$invalid_lock_reset,
     error_table_$lock_wait_time_exceeded,
     error_table_$locked_by_other_process,
     error_table_$locked_by_this_process,
     error_table_$namedup,
     error_table_$noentry,
     error_table_$not_initialized,
     error_table_$not_privileged,
     error_table_$unimplemented_version
     ) fixed bin (35) external static;

dcl  sys_info$max_seg_size fixed bin (18) external static;
dcl  sys_info$system_control_dir char (168) varying external static;


/* INTERNAL STATIC */

dcl  ACT_SEG_NAME char (32) internal static options (constant) init ("active_connection_list");
dcl  LOCK_WAIT_TIME fixed bin internal static options (constant) init (10);
dcl  static_connection_list_ptr pointer internal static init (null ());


/* BUILTINS AND CONDITIONS */

dcl  (addr, currentsize, length, mod, null, ptr, rel, string, unspec) builtin;
dcl  cleanup condition;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* add: entry to add a connection -- the caller is made both user and owner  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

add:
     entry (a_connection_name, a_connection_handle, a_service_type, a_force_disconnect, a_force_accounting, a_usage_type,
	a_offset, a_code);

	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	usage_type = a_usage_type;
	force_disc_entry = a_force_disconnect;
	force_acct_entry = a_force_accounting;
	connection_name = a_connection_name;
	connection_handle = a_connection_handle;
	service_type = a_service_type;

/* make sure we don't have one by this name already */

	call Find (connection_name, hash_index, offset, code);
	if code ^= 0
	then go to EXIT;				/* failure to find isn't an error */

	if offset ^= ""b
	then do;					/* in fact, in this case... */
	     code = error_table_$namedup;
	     go to EXIT;
	end;

/* now make a new entry */

	allocate active_connection in (active_connection_list.connection_area) set (act_ptr);

	unspec (active_connection) = ""b;		/* start clean */

	active_connection.version = ACT_VERSION_1;
	active_connection.connection_name = connection_name;
	active_connection.service_type = service_type;
	active_connection.owner_process_id, active_connection.user_process_id = get_process_id_ ();
	active_connection.owner_group_id, active_connection.user_group_id = get_group_id_ ();
	active_connection.force_disconnect_entry = force_disc_entry;
	active_connection.force_accounting_flush_entry = force_acct_entry;
	active_connection.connection_handle = connection_handle;
	active_connection.usage_type = usage_type;

	call Thread ();				/* threads to full list, hash list, and owner chain */

	call Thread_user ();

	a_offset = rel (act_ptr);

EXIT:
	if locked
	then call Unlock ();
	a_code = code;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* (priv hpriv)_delete_(name offset), delete_offset:		       */
/* The following group of entry points are used to delete a connection from  */
/* the list.  This call may be privileged, or highly privileged; and the     */
/* connection may be identified by either its name or its offset in the list */
/* segment.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_delete_name:
     entry (a_connection_name, a_code);

	priv_entry = "1"b;
	hpriv_entry = "0"b;
	name_entry = "1"b;
	go to DELETE_JOIN;


priv_delete_offset:
     entry (a_offset, a_code);

	priv_entry = "1"b;
	hpriv_entry = "0"b;
	name_entry = "0"b;
	go to DELETE_JOIN;

delete_offset:
     entry (a_offset, a_code);

	priv_entry = "0"b;
	hpriv_entry = "0"b;
	name_entry = "0"b;
	go to DELETE_JOIN;

hpriv_delete_name:
     entry (a_connection_name, a_code);

	priv_entry = "0"b;
	hpriv_entry = "1"b;
	name_entry = "1"b;
	go to DELETE_JOIN;


hpriv_delete_offset:
     entry (a_offset, a_code);

	priv_entry = "0"b;
	hpriv_entry = "1"b;
	name_entry = "0"b;

DELETE_JOIN:
	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	my_process_id = get_process_id_ ();

	if name_entry
	then do;					/* given the name, must find it */
	     connection_name = a_connection_name;
	     call Find (connection_name, hash_index, offset, code);
	     if code ^= 0
	     then go to EXIT;
	     if offset = ""b
	     then do;
		code = error_table_$noentry;
		go to EXIT;
	     end;
	end;

	else offset = a_offset;

	act_ptr = ptr (active_connection_list_ptr, offset);

	call Delete_one_entry ();			/* do it */
	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* XXX_delete_all_for_user:					       */
/* These two entry points delete all the connections of which a given	       */
/* process is the user; they may be invoked when the process in question     */
/* terminates.  The hpriv entry is called by a process other than the owner, */
/* in the event that the owner has also terminated or is otherwise	       */
/* unavailable.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_delete_all_for_user:
     entry (a_user_process_id, a_code);

	priv_entry = "1"b;
	hpriv_entry = "0"b;
	go to DELETE_ALL_JOIN;


hpriv_delete_all_for_user:
     entry (a_user_process_id, a_code);

	priv_entry = "0"b;
	hpriv_entry = "1"b;

DELETE_ALL_JOIN:
	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	user_process_id = a_user_process_id;

	next_act_ptr = Get_next_for_user (null (), user_process_id);
						/* get first one */

	do while (next_act_ptr ^= null ());
	     this_act_ptr = next_act_ptr;
	     next_act_ptr = Get_next_for_user (this_act_ptr, user_process_id);
						/* have to get next one before we delete this one */

	     act_ptr = this_act_ptr;			/* this little maneuver is required because */
						/*   Get_next_for_owner plays with act_ptr. */
	     call Delete_one_entry ();		/* to do the real work */
	end;

/* if Get_next_for_user returns null, there are no more */

	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* priv_change_user:  this entry is called by the owner of a connection to   */
/* assign it to a user process.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_change_user:
     entry (a_offset, a_user_process_id, a_user_group_id, a_usage_type, a_terminate_event_channel, a_handle, a_code);

	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	offset = a_offset;
	user_process_id = a_user_process_id;
	user_group_id = a_user_group_id;
	usage_type = a_usage_type;
	term_event_channel = a_terminate_event_channel;
	initializer_handle = a_handle;
	my_process_id = get_process_id_ ();

	act_ptr = ptr (active_connection_list_ptr, offset);
	if active_connection.version ^= ACT_VERSION_1
	then do;					/* not really an entry */
	     code = error_table_$noentry;
	     go to EXIT;
	end;

	if active_connection.owner_process_id ^= my_process_id
	then do;
	     code = error_table_$not_privileged;	/* not one we control */
	     go to EXIT;
	end;

	if active_connection.user_process_id ^= user_process_id
						/* see if it already belongs to this user */
	then do;
	     if active_connection.user_process_id ^= ""b	/* does it belong to anyone? */
	     then call Unthread_user ();		/* yes, unthread it from them */

	     active_connection.user_process_id = user_process_id;
	     call Thread_user ();
	end;

	active_connection.user_group_id = user_group_id;
	active_connection.owner_terminate_event_channel = term_event_channel;
	active_connection.owner_initializer_id = initializer_handle;
	active_connection.usage_type = usage_type;
	active_connection.delegated = "1"b;

	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* priv_remove_user:  this entry is called by the owner of a connection to   */
/* take it away from a user process without assigning it to a new one.       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_remove_user:
     entry (a_offset, a_user_process_id, a_code);

	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	offset = a_offset;
	user_process_id = a_user_process_id;
	my_process_id = get_process_id_ ();

	act_ptr = ptr (active_connection_list_ptr, offset);
	if active_connection.version ^= ACT_VERSION_1
	then do;					/* not really an entry */
	     code = error_table_$noentry;
	     go to EXIT;
	end;

	if active_connection.owner_process_id ^= my_process_id
	then do;
	     code = error_table_$not_privileged;	/* not one we control */
	     go to EXIT;
	end;
	if active_connection.user_process_id ^= user_process_id
						/* doesn't belong to who we thought it did */
	then do;
	     code = error_table_$noentry;
	     go to EXIT;
	end;

	call Unthread_user ();

	active_connection.user_process_id = active_connection.owner_process_id;
	active_connection.user_group_id = active_connection.owner_group_id;
	active_connection.delegated = ""b;

	call Thread_user ();

	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* hpriv_get_next: This entry gets the next connection after the specified   */
/* one (or the first one if the offset given is ""b).  It is used at	       */
/* login_server initialization in order to find orphaned connections.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

hpriv_get_next:
     entry (a_offset, a_connection_info_ptr, a_code);

	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	offset = a_offset;
	active_connection_info_ptr = a_connection_info_ptr;
	priv_entry = "0"b;
	hpriv_entry = "1"b;

	if offset = ""b
	then next_offset = active_connection_list.first_connection_offset;

	else do;
	     act_ptr = ptr (active_connection_list_ptr, offset);
	     next_offset = active_connection.next_connection;
	end;

	if next_offset = ""b
	then code = error_table_$noentry;

	else do;
	     act_ptr = ptr (active_connection_list_ptr, next_offset);
	     call Fill_info ();
	end;

	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* XXX_get_name:						       */
/* These two entry points return information for the connection with the     */
/* specified name.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_get_name:
     entry (a_connection_name, a_connection_info_ptr, a_code);

	priv_entry = "1"b;
	hpriv_entry = "0"b;
	go to GET_NAME_JOIN;


hpriv_get_name:
     entry (a_connection_name, a_connection_info_ptr, a_code);

	priv_entry = "0"b;
	hpriv_entry = "1"b;

GET_NAME_JOIN:
	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	connection_name = a_connection_name;
	active_connection_info_ptr = a_connection_info_ptr;

	call Find (connection_name, hash_index, offset, code);
	if code ^= 0
	then go to EXIT;
	if offset = ""b
	then do;
	     code = error_table_$noentry;
	     go to EXIT;
	end;

	act_ptr = ptr (active_connection_list_ptr, offset);
	call Fill_info ();
	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* XXX_get_next_user:					       */
/* The following entries return information about the next connection after  */
/* the one with the specified offset with the same user, or the first for    */
/* the given user if the offset is "0"b.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_get_next_user:
     entry (a_user_process_id, a_offset, a_connection_info_ptr, a_code);

	priv_entry = "1"b;
	hpriv_entry = "0"b;
	go to GET_NEXT_USER_JOIN;


hpriv_get_next_user:
     entry (a_user_process_id, a_offset, a_connection_info_ptr, a_code);

	priv_entry = "0"b;
	hpriv_entry = "1"b;

GET_NEXT_USER_JOIN:
	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	user_process_id = a_user_process_id;
	offset = a_offset;
	active_connection_info_ptr = a_connection_info_ptr;

	if offset = ""b
	then act_ptr = null ();
	else act_ptr = ptr (active_connection_list_ptr, offset);

	act_ptr = Get_next_for_user (act_ptr, user_process_id);
	if act_ptr ^= null ()
	then call Fill_info ();
	else code = error_table_$noentry;

	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* XXX_get_next_owner:					       */
/* The following entries return information about the next connection for    */
/* which the calling process is the owner (or the first such if offset is    */
/* "0"b).							       */
/*							       */
/* The highly privileged entrypoint returns information about a specified    */
/* owner.							       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

priv_get_next_owner:
     entry (a_offset, a_connection_info_ptr, a_code);

	priv_entry = "1"b;
	hpriv_entry = "0"b;
	owner_process_id = get_process_id_ ();

	go to GET_NEXT_OWNER_JOIN;


hpriv_get_next_owner:
     entry (a_offset, a_owner_process_id, a_connection_info_ptr, a_code);

	priv_entry = "0"b;
	hpriv_entry = "1"b;
	owner_process_id = a_owner_process_id;

GET_NEXT_OWNER_JOIN:
	active_connection_list_ptr = null;
	on cleanup call Unlock ();
	call Setup ();

	offset = a_offset;
	active_connection_info_ptr = a_connection_info_ptr;

	if offset = ""b
	then act_ptr = null ();
	else do;
	     act_ptr = ptr (active_connection_list_ptr, offset);
	     if active_connection.owner_process_id ^= owner_process_id
						/* this isn't the right process to begin with */
	     then do;
		if hpriv_entry
		then code = error_table_$noentry;
		else code = error_table_$not_privileged;
		go to EXIT;
	     end;
	end;

	act_ptr = Get_next_for_owner (act_ptr, owner_process_id);

	if act_ptr ^= null ()
	then call Fill_info ();
	else code = error_table_$noentry;
	go to EXIT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* init:							       */
/* This entry is called during system start up to create and initialize the  */
/* segment that contains the active connection table. The directory in which */
/* to create it is obtained from >sc1.  hash table size is a named constant  */
/* from the include file.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

init:
     entry (a_code);

	act_dir_name = sys_info$system_control_dir;
	hash_size = ACT_HASH_TABLE_SIZE;

	this_ring = get_ring_ ();
	call cu_$level_get (orig_level);

	on cleanup call cu_$level_set (orig_level);

	call cu_$level_set (this_ring);		/* need lower-ring validation level for initiation or creation */

	call initiate_file_ (act_dir_name, ACT_SEG_NAME, RW_ACCESS, active_connection_list_ptr, (0), code);

	if code = error_table_$noentry
	then do;					/* doesn't exist, we'll have to create it */

	     auto_create_branch_info.version = create_branch_version_2;
	     string (auto_create_branch_info.switches) = ""b;
	     auto_create_branch_info.mode = RW_ACCESS;
	     auto_create_branch_info.rings (*) = this_ring;
	     auto_create_branch_info.userid = "*.*.*";
	     auto_create_branch_info.bitcnt = 0;
	     auto_create_branch_info.quota = 0;

/* For debugging purposes, we will create the segment (in the user ring) at
   system low, but in real life it should be system_high.
*/
	     call convert_authorization_$from_string (sys_high_auth, "system_low" /* "system_high" */, code);
	     if code ^= 0
	     then go to INIT_EXIT;
	     auto_create_branch_info.access_class = sys_high_auth;
						/* make it multi-class */
	     auto_create_branch_info.dir_quota = 0;

	     call hcs_$create_branch_ (act_dir_name, ACT_SEG_NAME, addr (auto_create_branch_info), code);

	     if code = 0
	     then call initiate_file_ (act_dir_name, ACT_SEG_NAME, RW_ACCESS, active_connection_list_ptr, (0), code);
	end;

	call cu_$level_set (orig_level);		/* so's we don't forget */

	if code = 0
	then do;
	     call set_lock_$lock (active_connection_list.initializer_of_list, 0, code);
	     if code = error_table_$invalid_lock_reset
	     then code = 0;
	     else if code = error_table_$locked_by_other_process | code = error_table_$locked_by_this_process
		| code = error_table_$lock_wait_time_exceeded
	     then code = error_table_$already_initialized;
	end;

	if code = 0
	then do;					/* created or otherwise, we have it now */

/* initialize the contents */

	     active_connection_list.version = ACTL_VERSION_1;
	     active_connection_list.lock = ""b;
	     active_connection_list.no_of_connections = 0;
	     active_connection_list.first_connection_offset, active_connection_list.last_connection_offset = ""b;
	     active_connection_list.hash_table.size, actl_hash_table_size = hash_size;
	     active_connection_list.hash_table.entries (*) = ""b;

	     connection_area_size = 0;		/* so we can use currentsize */
	     words_used = currentsize (active_connection_list);
	     words_used = words_used + mod (words_used, 2);
						/* round up to even number */
	     call terminate_file_ (addr (active_connection_list), words_used * BITS_PER_WORD, TERM_FILE_TRUNC, code);

	     connection_area_size = sys_info$max_seg_size - words_used;
						/* rest of segment is available for area */

	     area_infop = addr (auto_area_info);

	     area_info.version = 1;
	     string (area_info.control) = ""b;
	     area_info.owner = get_group_id_ ();
	     area_info.size = connection_area_size;
	     area_info.areap = addr (active_connection_list.connection_area);
	     area_info.allocated_blocks, area_info.free_blocks, area_info.allocated_words, area_info.free_words = 0;

	     call define_area_ (area_infop, code);
	end;

INIT_EXIT:
	call cu_$level_set (orig_level);		/* in case we didn't do this before */

	a_code = code;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* 		I N T E R N A L     P R O C E D U R E S		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Delete_one_entry: deletes the connection list entry pointed to by	       */
/* act_ptr.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Delete_one_entry:
     procedure ();

	if active_connection.version ^= ACT_VERSION_1
	then do;
	     if name_entry
	     then code = error_table_$unimplemented_version;
	     else code = error_table_$noentry;
	     go to EXIT;
	end;

	if hpriv_entry
	then ;
	else if priv_entry
	then if active_connection.owner_process_id ^= my_process_id
	     then do;				/* we don't own this one */
		code = error_table_$not_privileged;
		go to EXIT;
	     end;
	     else ;

	else if active_connection.user_process_id ^= my_process_id
	then do;					/* no privileges, we should be user */
	     code = error_table_$not_privileged;
	     go to EXIT;
	end;

	call Unthread_user ();			/* take it out of user chain */
	call Unthread ();				/* and others */

	active_connection.version = "";		/* make sure it doesn't look like a good entry */
	active_connection.connection_name = "";

	free active_connection in (active_connection_list.connection_area);
						/* get the space back */

     end Delete_one_entry;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Fill_info: fills in the active_connection_info structure for the current  */
/* entry.							       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Fill_info:
     procedure ();

	if active_connection_info.version ^= ACT_INFO_VERSION_1
	then do;
	     code = error_table_$unimplemented_version;
	     return;
	end;

	active_connection_info.connection_name = active_connection.connection_name;
	active_connection_info.network_service_type = active_connection.service_type;
	active_connection_info.user_process_id = active_connection.user_process_id;
	active_connection_info.user_group_id = active_connection.user_group_id;
	active_connection_info.owner_process_id = active_connection.owner_process_id;
	active_connection_info.owner_group_id = active_connection.owner_group_id;
	active_connection_info.terminate_event_channel = active_connection.owner_terminate_event_channel;
	active_connection_info.owner_initializer_handle = active_connection.owner_initializer_id;
	active_connection_info.force_disconnect_entry = active_connection.force_disconnect_entry;
	active_connection_info.force_accounting_flush_entry = active_connection.force_accounting_flush_entry;
	active_connection_info.connection_handle = active_connection.connection_handle;
	active_connection_info.usage_type = active_connection.usage_type;
	active_connection_info.flags.delegated = active_connection.flags.delegated;
	active_connection_info.offset = rel (act_ptr);

	return;

     end Fill_info;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Find:							       */
/* Searches the list (using the hash table) for a connection with the	       */
/* specified name, and returns its offset if one is found. Also returns the  */
/* index to which the name hashes, for later use in threading/unthreading.   */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Find:
     procedure (a_connection_name, a_hash_index, a_offset, a_code);



dcl  a_connection_name char (32) parameter;
dcl  a_hash_index fixed bin parameter;
dcl  a_offset bit (18) parameter;
dcl  a_code fixed bin (35) parameter;

dcl  hash_value fixed bin;
dcl  connection_name char (32) aligned;
dcl  offset bit (18);
dcl  found bit (1);

	connection_name = a_connection_name;
	hash_value =
	     hash_index_ (addr (connection_name), length (connection_name), (0), active_connection_list.hash_table.size)
	     + 1;					/* our table is 1-based, but hash_index_'s result is 0-based */
	offset = active_connection_list.hash_table.entries (hash_value);

	if offset ^= ""b				/* if there are any names that hash to this value */
	then do;
	     found = "0"b;

	     do while ((^found) & (offset ^= ""b));	/* find the one that actually has the same name */
		act_ptr = ptr (active_connection_list_ptr, offset);
		if active_connection.connection_name = connection_name
		then found = "1"b;
		else offset = active_connection.next_hash;
						/* not this one, check next */
	     end;
	end;

	a_offset = offset;				/* = ""b if name not found */
	a_hash_index = hash_value;			/* valid in any case */
	a_code = 0;				/* always */
	return;

     end Find;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Get_next_for_user:					       */
/* Returns a pointer to the next connection for the same user (and, if not   */
/* the hpriv entry, the same owner) after the one input; or the first one if */
/* a_act_ptr is null.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Get_next_for_user:
     procedure (a_act_ptr, a_process_id) returns (pointer);

dcl  a_act_ptr pointer parameter;
dcl  a_process_id bit (36) parameter;

dcl  found bit (1);
dcl  my_process_id bit (36);
dcl  next_offset bit (18);
dcl  owner_process_id bit (36);
dcl  user_process_id bit (36);

	act_ptr = a_act_ptr;
	user_process_id = a_process_id;
	my_process_id = get_process_id_ ();

	if act_ptr ^= null ()			/* we were given one, find next */
	then do;
	     next_offset = active_connection.next_connection_for_user;
	     if next_offset = ""b			/* there isn't one */
	     then return (null ());
	     act_ptr = ptr (active_connection_list_ptr, next_offset);
						/* this is the one we will consider */
	end;

	else do;					/* given nul pointer, we'll have to find first one */
	     found = "0"b;
	     do next_offset = active_connection_list.first_connection_offset
		repeat (active_connection.next_connection) while ((next_offset ^= ""b) & (^found));
		act_ptr = ptr (active_connection_list_ptr, next_offset);
		if active_connection.user_process_id = user_process_id
		then found = "1"b;
	     end;

	     if ^found
	     then return (null ());			/* there weren't any */
	end;

/* if not privileged entry, make sure we're the owner */

	if ^hpriv_entry
	then do while (active_connection.owner_process_id ^= my_process_id);
	     next_offset = active_connection.next_connection_for_user;
	     if next_offset = ""b			/* we ran out */
	     then return (null ());
	     else act_ptr = ptr (active_connection_list_ptr, next_offset);
	end;

	return (act_ptr);				/* if we get to here, we've got the right one */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Get_next_for_owner:					       */
/* Likewise, but returns a pointer to the next one for the given owner       */
/* process.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Get_next_for_owner:
     entry (a_act_ptr, a_process_id) returns (pointer);

	act_ptr = a_act_ptr;
	owner_process_id = a_process_id;

	if act_ptr ^= null ()			/* we were given one, find next */
	then do;
	     next_offset = active_connection.next_connection_for_owner;
	     act_ptr = ptr (active_connection_list_ptr, next_offset);
						/* this is the one we will consider */
	     if next_offset = ""b			/* there isn't one */
	     then return (null ());
	     else return (act_ptr);
	end;

	else do;					/* have to find first one */
	     do next_offset = active_connection_list.first_connection_offset
		repeat (active_connection.next_connection) while (next_offset ^= ""b);
		act_ptr = ptr (active_connection_list_ptr, next_offset);
		if active_connection.owner_process_id = owner_process_id
		then return (act_ptr);		/* this is it */
	     end;

	     return (null ());			/* there weren't any */
	end;

     end Get_next_for_user;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Lock:  lock the active connection table.			       */
/* Unlock: unlock it.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Lock:
     procedure (a_code) returns (bit (1));

dcl  a_code fixed bin (35) parameter;

dcl  code fixed bin (35);

	call set_lock_$lock (active_connection_list.lock, LOCK_WAIT_TIME, code);

	if code = 0 | code = error_table_$invalid_lock_reset
	then do;
	     a_code = 0;
	     return ("1"b);
	end;

	else do;
	     a_code = code;
	     return ("0"b);
	end;

     end Lock;


Unlock:
     procedure ();

dcl  code fixed bin (35);

	if active_connection_list_ptr ^= null
	then call set_lock_$unlock (active_connection_list.lock, code);
	return;

     end Unlock;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Setup:							       */
/* 1) Initialize code variable to 0.				       */
/* 2) Get pointer to active_connection_list segment if we don't already have */
/*    a static copy.					       */
/* 3) Lock the connection table.				       */
/* 4) Make sure the table has been initialized this bootload.  If not,       */
/*    return error back to caller.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Setup:
     procedure ();

	act_dir_name = sys_info$system_control_dir;
	code = 0;
	locked = "0"b;
	if static_connection_list_ptr = null ()		/* first use in this process */
	then do;
	     call cu_$level_get (orig_level);

	     on cleanup call cu_$level_set (orig_level);

	     call cu_$level_set (get_ring_ ());		/* need lower-ring validation level for initiation or creation */
	     call initiate_file_ (act_dir_name, ACT_SEG_NAME, RW_ACCESS, static_connection_list_ptr, (0), code);
	     call cu_$level_set (orig_level);
	     if code ^= 0
	     then go to EXIT;
	end;

	active_connection_list_ptr = static_connection_list_ptr;

	locked = Lock (code);
	if code ^= 0
	then go to EXIT;

/* make sure database has been initialized this bootload */
	temp_lock_word = active_connection_list.initializer_of_list;
	call set_lock_$lock (temp_lock_word, 0, code);
	if code = error_table_$invalid_lock_reset
	then do;
	     code = error_table_$not_initialized;
	     go to EXIT;
	end;
	else if code = error_table_$locked_by_other_process | code = error_table_$locked_by_this_process
	     | code = error_table_$lock_wait_time_exceeded
	then code = 0;
	if code ^= 0
	then go to EXIT;
	return;

     end Setup;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Thread: threads a connection into:				       */
/*  1) the list of all connections,				       */
/*  2) the threaded list by owner, and				       */
/*  3) the list sharing a hash index.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Thread:
     procedure ();

dcl  found bit (1);
dcl  hash_value fixed bin;
dcl  last_hash bit (18);
dcl  next_act_ptr pointer;
dcl  next_hash bit (18);
dcl  next_offset bit (18);
dcl  offset bit (18);
dcl  prev_act_ptr pointer;
dcl  prev_hash bit (18);
dcl  prev_offset bit (18);
dcl  temp_act_ptr pointer;

	offset = rel (act_ptr);
	if active_connection_list.hash_table.entries (hash_index) = ""b
	then do;					/* this is the first one with this hash_index */
	     active_connection_list.hash_table.entries (hash_index) = offset;
	     active_connection.prev_hash = ""b;
	end;

	else do;					/* hash slot occupied, thread it to hash list */
	     do last_hash = active_connection_list.hash_table.entries (hash_index) repeat (next_hash)
		while (last_hash ^= ""b);
		temp_act_ptr = ptr (active_connection_list_ptr, last_hash);
		next_hash = temp_act_ptr -> active_connection.next_hash;
		prev_hash = last_hash;
	     end;

	     temp_act_ptr -> active_connection.next_hash = offset;
	     active_connection.prev_hash = prev_hash;
	end;

	active_connection.next_hash = ""b;		/* in any case */

/* now thread into owner list */

	found = "0"b;
	do prev_offset = active_connection_list.last_connection_offset
	     repeat (temp_act_ptr -> active_connection.prev_connection) while ((prev_offset ^= ""b) & (^found));
	     temp_act_ptr = ptr (active_connection_list_ptr, prev_offset);
	     if temp_act_ptr -> active_connection.owner_process_id = active_connection.owner_process_id
	     then found = "1"b;			/* we found the end of the list for this owner */
	end;

	if found
	then do;
	     active_connection.prev_connection_for_owner = rel (temp_act_ptr);
	     temp_act_ptr -> active_connection.next_connection_for_owner = offset;
	end;

	else active_connection.prev_connection_for_owner = ""b;
						/* there aren't any others yet */

	active_connection.next_connection_for_owner = ""b;/* in any case */

/* now thread it onto end of list of all connections */

	active_connection.prev_connection = active_connection_list.last_connection_offset;
	active_connection.next_connection = ""b;

	if active_connection_list.last_connection_offset = ""b
	then do;					/* this is the very first one */
	     active_connection_list.first_connection_offset, active_connection_list.last_connection_offset = offset;
	end;

	else do;
	     temp_act_ptr = ptr (active_connection_list_ptr, active_connection_list.last_connection_offset);
	     temp_act_ptr -> active_connection.next_connection = offset;
	     active_connection_list.last_connection_offset = offset;
	end;

	active_connection_list.no_of_connections = active_connection_list.no_of_connections + 1;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Thread_user:						       */
/* threads a connection into the list by user.  It finds the previous one    */
/* for the same user by chasing back the global connection threads.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Thread_user:
     entry ();

	offset = rel (act_ptr);
	if active_connection.prev_connection = ""b
	then prev_act_ptr = null ();

	else do;
	     found = "0"b;
	     do prev_offset = active_connection.prev_connection
		repeat (prev_act_ptr -> active_connection.prev_connection) while ((prev_offset ^= ""b) & (^found));
		prev_act_ptr = ptr (active_connection_list_ptr, prev_offset);
		if prev_act_ptr -> active_connection.user_process_id = active_connection.user_process_id
		then found = "1"b;
	     end;

	     if ^found
	     then prev_act_ptr = null ();
	end;

	if prev_act_ptr ^= null ()
	then do;
	     next_offset = prev_act_ptr -> active_connection.next_connection_for_user;
	     if next_offset = ""b
	     then next_act_ptr = null ();
	     else next_act_ptr = ptr (active_connection_list_ptr, next_offset);
	end;

	else do;					/* none before it, find the first one after it */
	     if active_connection.next_connection = ""b
	     then next_act_ptr = null ();

	     else do;
		found = "0"b;
		do next_offset = active_connection.next_connection
		     repeat (next_act_ptr -> active_connection.next_connection)
		     while ((next_offset ^= ""b) & (^found));
		     next_act_ptr = ptr (active_connection_list_ptr, next_offset);
		     if next_act_ptr -> active_connection.user_process_id = active_connection.user_process_id
		     then found = "1"b;
		end;

		if ^found
		then next_act_ptr = null ();
	     end;
	end;

/* Having found next and/or previous, do the actual threading */

	if next_act_ptr = null ()
	then active_connection.next_connection_for_user = ""b;

	else do;
	     active_connection.next_connection_for_user = rel (next_act_ptr);
	     next_act_ptr -> active_connection.prev_connection_for_user = offset;
	end;

	if prev_act_ptr = null ()
	then active_connection.prev_connection_for_user = ""b;

	else do;
	     active_connection.prev_connection_for_user = rel (prev_act_ptr);
	     prev_act_ptr -> active_connection.next_connection_for_user = offset;
	end;

	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Unthread: removes a connection from:				       */
/*  1) the list of all connections,				       */
/*  2) the owner list, and					       */
/*  3) the list sharing a hash index.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Unthread:
     entry ();

/* Owner list first */

	if active_connection.prev_connection_for_owner ^= ""b
	then do;
	     prev_act_ptr = ptr (active_connection_list_ptr, active_connection.prev_connection_for_owner);
	     prev_act_ptr -> active_connection.next_connection_for_owner = active_connection.next_connection_for_owner;
	end;

	if active_connection.next_connection_for_owner ^= ""b
	then do;
	     next_act_ptr = ptr (active_connection_list_ptr, active_connection.next_connection_for_owner);
	     next_act_ptr -> active_connection.prev_connection_for_owner = active_connection.prev_connection_for_owner;
	end;

/* now hash list */

	if active_connection.next_hash ^= ""b
	then do;
	     next_act_ptr = ptr (active_connection_list_ptr, active_connection.next_hash);
	     next_act_ptr -> active_connection.prev_hash = active_connection.prev_hash;
	end;

	if active_connection.prev_hash ^= ""b
	then do;
	     prev_act_ptr = ptr (active_connection_list_ptr, active_connection.prev_hash);
	     prev_act_ptr -> active_connection.next_hash = active_connection.next_hash;
	end;

	else do;					/* this was first one in hash list, update hash table entry */
	     hash_value =
		hash_index_ (addr (active_connection.connection_name), length (active_connection.connection_name),
		(0), active_connection_list.hash_table.size) + 1;
						/* because our table is 1-based */
	     active_connection_list.hash_table.entries (hash_value) = active_connection.next_hash;
	end;

	active_connection.prev_hash, active_connection.next_hash = ""b;

/* now unthread it from list of all connections */

	if active_connection.next_connection ^= ""b
	then do;
	     next_act_ptr = ptr (active_connection_list_ptr, active_connection.next_connection);
	     next_act_ptr -> active_connection.prev_connection = active_connection.prev_connection;
	end;

	else active_connection_list.last_connection_offset = active_connection.prev_connection;

	if active_connection.prev_connection ^= ""b
	then do;
	     prev_act_ptr = ptr (active_connection_list_ptr, active_connection.prev_connection);
	     prev_act_ptr -> active_connection.next_connection = active_connection.next_connection;
	end;

	else active_connection_list.first_connection_offset = active_connection.next_connection;

	active_connection.prev_connection, active_connection.next_connection = ""b;

	active_connection_list.no_of_connections = active_connection_list.no_of_connections - 1;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Unthread_user:						       */
/* removes a connection from the list threaded by user.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Unthread_user:
     entry ();

	if active_connection.prev_connection_for_user ^= ""b
	then do;
	     prev_act_ptr = ptr (active_connection_list_ptr, active_connection.prev_connection_for_user);
	     prev_act_ptr -> active_connection.next_connection_for_user = active_connection.next_connection_for_user;
	end;

	if active_connection.next_connection_for_user ^= ""b
	then do;
	     next_act_ptr = ptr (active_connection_list_ptr, active_connection.next_connection_for_user);
	     next_act_ptr -> active_connection.prev_connection_for_user = active_connection.prev_connection_for_user;
	end;

	active_connection.prev_connection_for_user, active_connection.next_connection_for_user = ""b;

	return;

     end Thread;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 %include access_mode_values;
 %include active_connection_list;
 %include active_connection_info;
 %include area_info;
 %include create_branch_info;
 %include system_constants;
 %include terminate_file;

     end connection_list_manager_;




		    dial_ctl_.pl1                   05/16/89  1058.6rew 05/16/89  1053.1      946719



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-08-07,Swenson), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     to check for access on "tandd.acs" rather than just "tandd".  Also, to
     log errors received when issuing tandd_attach control order.
  2) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  3) change(86-06-29,Swenson), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Modified to check anstbl.login_server_present before calling
     uc_cleanup_network_dials_ to ensure that the MNA RPQ code is only invoked
     if it is present.
  4) change(86-07-18,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to not attempt to logout channels whose service type is not
     normally login-type.
     (Actual change date was 85-07-18)
  5) change(86-07-23,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to increase the maximum length of "reason" so entire audit
     message can be displayed.
     (Actual change date was 85-07-23)
  6) change(86-07-23,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to require RW access to ACS path before allowing access to
     channels.
     (Actual change date was 85-07-23)
  7) change(86-07-24,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to check the dialok attribute for the terminate_dial_out request
     for consistency with all other requests.
     (Actual change date was 85-07-24)
  8) change(86-07-24,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to send control messages for all granted requests.
     (Actual change date was 85-07-24)
  9) change(86-07-24,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to ensure dial_out requests check the service type of the
     requested channel before attempting to see if it is in use.
     (Actual change date was 85-07-24)
 10) change(86-07-25,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to fix various small bugs which prevented correct operation
     during functional testing.
     (Actual change date was 85-07-25)
 11) change(86-07-27,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to ensure a channel's access class is correct before using it in
     access calculations.  Also to reset the access class when the channel
     hangs up.
     (Actual change date was 85-07-25)
 12) change(86-10-14,Lippard), approve(85-12-30,MCR7326),
     audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200):
     Modified to use as_request_sender version 2.
 13) change(87-04-03,Parisek), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Test for variable size before assigning value to variable to prevent
     stringsize errors.
 14) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
 15) change(87-06-01,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Expand aliases in "dial DIAL_ID person.project".
 16) change(87-06-12,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
      A) Change to audit all dial actions via as_access_audit_$channel,
         rather than doing some there and some by direct calls to sys_log_.
 17) change(87-06-23,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct format of "dial system" audit messages.
      B) Avoid calling as_access_audit_ when no process is associated with
         the operation.
 18) change(88-11-28,Farley), approve(88-12-14,MCR8035),
     audit(89-05-15,Parisek), install(89-05-16,MR12.3-1045):
     Corrected look_for_channel procedure to check for a "no available device"
     error before checking for a "bad access" error.
                                                   END HISTORY COMMENTS */

/* format: style2,indcomtxt,^inddcls,^indattr */

dial_ctl_:
     procedure (P_cdtep, P_dial_qualifier, P_target_person_project, P_code);

/* DIAL_CTL_ - answering service module which handles "dial" preaccess
   commands, user requests to attach, release, dial_out, and tandd_attach
   communications channels. */

/*
   Modified 750117 by PG for dial_qualifiers.
   Modified 750307 by PG for dialing to absentee and daemon processes.
   Modified 750716 by PG to get privileged attach to work.
   Modified 750812 by PG & THVV for cdt.
   Modified 03/18/76 by David Jordan for Auto Call.
   Modified 07/20/76 by D. M. Wells to use new WAIT_DIAL_GRAB cdte state
   Modified 760819 by Roy Planalp to produce special messages for ftp users
   Modified Aug-Sept 1976 by M. Grady and T. Casey to properly dispose of a dialed channel whose master process terminated
   Modified by S.T. Kent Nov-Dec 1976 to add registered dial qualifier facility
   and facility to release a selected dialed channel.
   Modified by D. M. Wells, May, 1977, to fix bug wrt slave channels and to
   improve error messages.
   Modified by Robert Coren, June, 1977, to use new terminal type stuff.
   Modified November 1978 by Larry Johnson to pass devx's in dial messages
   because channel names became longer than 6 characters.
   Modified April 1979 by T. Casey for MR7.0a to eliminate "s" as a synonym for "system" in the dial command.
   Modified April 1979 by Larry Johnson for no_hangup feature of release_channel.
   Modified July 1979 by C. Hornig to properly recognize non-FNP MCS channels.
   Modified September 1979 by Larry Johnson to set terminal types on slave channels.
   Modified November 1980 by Art Beattie to only look for dial out channels on loaded multiplexers and correct
   error messages.
   Modified November 1980 by E.N. Kittlitz for new dialout requests, cleanup and bugfixes.
   Modified March 1981 by Robert Coren for T & D attachments.
   Modified April 1981 by Robert Coren to issue copy_meters order when assigning channel.
   Modified April 1981 by E. N. Kittlitz for cdte.dial_ev_chn.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified April 1982, E. N. Kittlitz. New AS initialization.
   Modified July 1982, E. N. Kittlitz. Support MCS channel (un)masking.
   Modified November 1982, E. N. Kittlitz.  don't use masked dial-out channels.
   Modified January 1983, Keith Loepere for generic_destination and so
   priv_attach also scans for suitable channel.
   Modified May 1983, E. N. Kittlitz. required access class support for AIMish stys.
   Modified 831216, E. N. Kittlitz. fix required access class, dial_out, when mux is down.
   Modified 840211, Jeffrey I. Schiller fix required access class for "dial" command.
   Modified 84-04-05 BIM to finish channel AIM, recasting required access class.
   Modified 84-04-20 BIM to add tracing to debug above.
   Modified 1984-09-28 BIM to fix t&d attach, log release, change trace sv.
   Modified 1984-10-03 BIM to use fake_connect protocol for t&d failures.
   Modified 1984-10-04 BIM to use up_sysctl_$check_acs for tandd.acs
   Modified 1984-10-17 by E. Swenson to clean up error reporting and
   logging and, in doing so, audit some events that should be audited.
   Modified 1985-01-23 by E. Swenson for new A.S. auditing.
   Modified 1985-02-19 BIM to clear out user_name on release.
   Modified 1985-04-11 by E. Swenson to fix mangled log message.
*/

/* Parameters */

dcl     P_cdtep ptr parameter;			/* pointer to channel entry for console */
dcl     P_dial_qualifier char (*) parameter;		/* dial qualifier */
dcl     P_target_person_project char (*) parameter;	/* target Person.Project */
dcl     P_code fixed bin (35) parameter;

/* Automatic */

dcl     acs_name char (32);				/* for cheching .acs segs */
dcl     bf fixed bin (71) based;			/* overlay for event msg */
dcl     buffer char (200) aligned;
dcl     1 CAI structure aligned like channel_audit_info automatic;
dcl     cdtx fixed bin;				/* used by find_cdte */
dcl     chn fixed bin (71);				/* event channel */
dcl     code fixed bin (35);				/* error code */
dcl     date char (50);				/* for date_time_ */
dcl     desired_channel char (32);			/* from dsr.channel_name if allowing starnames */
dcl     dial_qualifier char (32);
dcl     dial_out_used_privilege bit (1) aligned;
dcl     1 DSI aligned like dial_server_info automatic;	/* for as_access_audit_ */
dcl     find_person_project bit (1) aligned;
dcl     format char (100) aligned;			/* for connected to system message */
dcl     i fixed bin;				/* counter */
dcl     junk char (8) aligned;
dcl     mcode fixed bin (35);				/* output message */
dcl     added_info char (128);			/* additional info for log messages */
dcl     mode bit (36) aligned;
dcl     phone_data char (32) varying;			/* from dsr.dial_out_destination */
dcl     process_id bit (36) aligned init (""b);
dcl     process_destroyed_flag bit (1) aligned automatic;
dcl     process_group_id char (32) init ("?");
dcl     process_ring fixed bin (3) init (7);
dcl     reason char (256);				/* error message component */
dcl     reason_code fixed bin (35);			/* error code associated with reason */
dcl     request_type fixed bin (17) initial (0);		/* type of request, if any */
dcl     requested_access_class bit (72) aligned;
dcl     retval fixed bin (71);			/* signal to user (see "rv") */
dcl     rq_person char (22);				/* for looking up user */
dcl     rq_project char (9);				/* for looking up user */
dcl     rvp ptr;					/* pointer to retval */
dcl     server_authorization char (100);
dcl     star_channel_name bit (1) aligned;		/* we have a starname channel specification */
dcl     suppress_listen bit (1);
dcl     target_person_project char (32);
dcl     used_privilege bit (1) aligned;
dcl     user_lth fixed bin;
dcl     user_string char (100);
dcl     word char (8) aligned;

dcl     1 term_info like terminal_info;

dcl     1 set_type_info like set_term_type_info;

/* Constant */

dcl     (
        JUST_DIALED bit (15) aligned initial ("77770"b3),
        JUST_HUNGUP bit (15) aligned initial ("77771"b3),
        REQUEST_GRANTED bit (15) aligned initial ("77772"b3),
        REQUEST_DENIED bit (15) aligned initial ("77773"b3)
        ) internal static options (constant);

dcl     ME char (9) init ("dial_ctl_") static options (constant);

declare (
        PRIV_ATTACH init (1),
        DIAL_OUT init (2),
        DIAL_IN init (3),
        T_AND_D init (4)
        ) fixed bin internal static options (constant);

dcl     ATTACHMENT_TYPES (1:4) char (12) internal static options (constant)
	   initial ("priv_attach", "dial_out", "dial_in", "t&d_attach");

dcl     (
        UNKNOWN_RQ initial (0),
        START_DIAL_ID_RQ initial (1),
        STOP_DIAL_ID_RQ initial (2),
        RELEASE_CHN_RQ initial (3),
        PRIV_ATTACH_CHN_RQ initial (4),
        TANDD_ATTACH_CHN_RQ initial (5),
        RELEASE_DIAL_ID_RQ initial (6),
        DIAL_OUT_RQ initial (7),
        TERMINATE_DIAL_OUT_RQ initial (8)
        ) fixed bin (17) internal static options (constant);

dcl     REQUEST_TYPES (0:8) char (20) internal static options (constant)
	   initial ("unknown", "start dial service", "stop dial service", "release channel", "priv attach",
	   "tandd attach", "release dial service", "dial out", "terminate dial out");

dcl     (
        TRUE initial ("1"b),
        FALSE initial ("0"b)
        ) bit (1) aligned internal static options (constant);

/* external static */

dcl     as_error_table_$dialagain fixed bin (35) external;
dcl     as_error_table_$dialup_error fixed bin (35) ext static;
dcl     as_error_table_$dial_connect_msg fixed bin (35) external;
dcl     as_error_table_$dialdied fixed bin (35) external;
dcl     as_error_table_$dialnoline fixed bin (35) external;
dcl     as_error_table_$dialnotup fixed bin (35) external;
dcl     as_error_table_$dial_sys_msg fixed bin (35) external;
dcl     error_table_$action_not_performed fixed bin (35) external static;
dcl     error_table_$ai_restricted fixed bin (35) ext static;
dcl     error_table_$ai_out_range fixed bin (35) static external;
dcl     error_table_$bad_name fixed bin (35) static external;
dcl     error_table_$badstar fixed bin (35) static external;
dcl     error_table_$dial_active fixed bin (35) static external;
dcl     error_table_$dial_id_busy fixed bin (35) static external;
dcl     error_table_$id_not_found fixed bin (35) static external;
dcl     error_table_$insufficient_access fixed bin (35) static external;
dcl     error_table_$invalid_resource_state fixed bin (35) static external;
dcl     error_table_$io_no_permission fixed bin (35) static external;
dcl     error_table_$name_not_found fixed bin (35) static external;
dcl     error_table_$noentry fixed bin (35) ext static;
dcl     error_table_$no_connection fixed bin (35) static external;
dcl     error_table_$no_dialok fixed bin (35) static external;
dcl     error_table_$order_error fixed bin (35) static external;
dcl     error_table_$request_not_recognized fixed bin (35) static external;
dcl     error_table_$request_pending fixed bin (35) external;
dcl     error_table_$resource_attached fixed bin (35) ext static;
dcl     error_table_$resource_not_free fixed bin (35) static external;
dcl     error_table_$resource_unavailable fixed bin (35) static external;
dcl     error_table_$resource_unknown fixed bin (35) static external;
dcl     error_table_$unable_to_check_access fixed bin (35) static external;
dcl     error_table_$undefined_order_request fixed bin (35) static external;
dcl     error_table_$unimplemented_version fixed bin (35) static external;

/* Builtin */

dcl     (addr, addrel, after, before, bit, fixed, float, hbound, lbound, length, low, null, rtrim, string, substr, unspec)
	   builtin;

/* Entries */

dcl     aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
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_util_$get_access_class entry (bit (72) aligned) returns (bit (72) aligned);
dcl     as_access_audit_$channel entry (ptr, ptr, ptr, fixed bin, ptr, char (*));
dcl     as_access_audit_$dialid entry (ptr, fixed bin, ptr, char (*));
dcl     as_any_other_handler_ entry (char (*), entry, label, label);
dcl     astty_$tty_changemode entry (ptr, char (*), fixed bin (35));
dcl     astty_$tty_detach entry (ptr, fixed bin, fixed bin (35));
dcl     astty_$tty_force entry (ptr, ptr, fixed bin, fixed bin (35));
dcl     astty_$tty_new_proc entry (ptr, bit (36) aligned, fixed bin (35));
dcl     astty_$tty_order entry (ptr, char (*), ptr, fixed bin (35));
dcl     astty_$tty_state entry (ptr, fixed bin (35));
dcl     asu_$asu_listen entry (ptr, fixed bin (35));
dcl     asu_$find_process entry (bit (36) aligned, fixed bin, ptr);
dcl     asu_$format_ftp_msg entry (char (200) aligned, fixed bin, fixed bin, fixed bin) returns (char (200) aligned);
dcl     asu_$reset_access_class entry (pointer);
dcl     asu_$write_chn_message entry (ptr, fixed bin (35), char (8) aligned, fixed bin (35));
dcl     check_star_name_$entry entry (char (*), fixed bin (35));
dcl     convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl     convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl     date_time_$format entry (character (*), fixed binary (71), character (*), character (*))
	   returns (character (250) var);
dcl     display_access_class_ entry (bit (72) aligned) returns (character (32) aligned);
dcl     device_acct_$off entry (fixed bin, char (*) aligned, ptr);
dcl     device_acct_$on entry (fixed bin, char (*) aligned, ptr);
dcl     get_process_access_class_ entry () returns (bit (72) aligned);
dcl     hash_$search entry (ptr, char (*), fixed bin (35), 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_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl     ioa_$rs entry options (variable);
dcl     ioa_$rsnnl entry options (variable);
dcl     ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl     lg_ctl_$logout_channel entry (ptr, char (*));
dcl     match_star_name_ entry (char (*), char (*), fixed bin (35));
dcl     pathname_ entry (character (*), character (*)) returns (character (168));
dcl     pnt_manager_$admin_get_entry entry (char (*), ptr, fixed bin (35));
dcl     sys_log_ entry options (variable);		/* type to operator */
dcl     sys_log_$error_log entry options (variable);	/* log error using error_table_ code */
dcl     ttt_info_$initial_string entry (char (*), char (*) varying, fixed bin (35));
dcl     ttt_info_$modes entry (char (*), char (*), fixed bin (35));
dcl     uc_cleanup_network_dials_ entry (bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl     up_sysctl_$check_acs entry (char (*), char (*), fixed bin, bit (36) aligned, fixed bin (35));

/* Based */

dcl     1 rv based (rvp) aligned,			/* overlay, for return signal */
	2 chan char (6) unaligned,			/* name of tty dialing, or "contrl" */
	2 control unaligned,
	  3 devx_msg bit (1),			/* indicates rv.chan contains a devx, not a name */
	  3 error_msg bit (1),			/* indicates rv.chan contains an error code, not a name */
	  3 pad bit (1),
	  3 code bit (15);				/* what happened */

/* Static */

dcl     static_trace_sw bit (1) internal static init ("0"b);

/* Conditions */

dcl     any_other condition;
%page;
/* Program */

/* dial_ctl_: procedure (P_cdtep, P_dial_qualifier, P_target_person_project, P_code); */

/**** This entrypoint handles the "dial" preaccess command.  On entry,
      P_cdtep points to the cdte of the channel requesting the dial,
      P_dial_qualifier is the specified dial_id, P_target_person_project,
      if present, is the User_id.Project_id combination. */

	if as_data_$ansp = null
	then return;				/* if not initialized */
	ansp = as_data_$ansp;

	cdtep = P_cdtep;				/* Get pointer to channel giving request */
	dial_qualifier = P_dial_qualifier;		/* copy dial qualifier */
	target_person_project = P_target_person_project;

	utep = null ();				/* initialize so that we don't fault */
	reason_code = 0;
	reason = "";

	if dial_qualifier = ""
	then do;					/* didn't say who */
		call ABORT_DIALIN (as_error_table_$dialnoline, "");
		return;
	     end;

	if static_trace_sw
	then call trace ("(dial_ctl_) Channel ^a Qualifier ^a ^[user ^a^]", cdte.name, dial_qualifier,
		(target_person_project ^= ""), target_person_project);

/**** lg_ctl_ has already blessed this dial as far as the user giving
      the dial request and the channel AIM. cdte.current_access_class
      contains the access class of the dial, which must be consistent
      with that of the receiving process. */

/* Is this an attempt to dial the initializer? */

	if dial_qualifier = "system"
	then do;
/**** The current access class will only be invalid if the check_acs flag
      for dial_in is not on for this channel. */
		if cdte.current_access_class_valid
		then if ^aim_check_$equal (cdte.current_access_class (1), get_process_access_class_ ())
		     then do;
			     call ABORT_DIALIN (error_table_$ai_out_range, "Channel not system_low");
			     return;
			end;

		call convert_status_code_ (as_error_table_$dial_sys_msg, junk, format);
		call ioa_$rs (format, buffer, i,	/* Acknowledge connection. Disclose channel id. */
		     cdte.current_terminal_type, cdte.tty_id_code, cdte.name);
		if cdte.service_type = FTP_SERVICE
		then buffer = asu_$format_ftp_msg (buffer, i, i, 230);
						/* generate FTP msg */
		call astty_$tty_force (cdtep, addr (buffer), i, code);
		if cdte.state < TTY_DIALED
		then do;				/* channel hungup */
			call ABORT_DIALIN (0, "channel hungup");
			return;
		     end;
		P_code = 0;			/* Initializer always accepts dial. */
		dutp = as_data_$dutp;		/* Initializer   */
		utep = addr (dutbl.entry (1));	/* UTE	       */
		cdte.process = utep;
		cdte.in_use = NOW_LOGGED_IN;
		cdte.tra_vec = WAIT_DIAL_RELEASE;	/* Branch to right place if hangup */
		cdte.dialed_to_procid = anstbl.as_procid;
		cdte.dial_ev_chn = -1;		/* This value should never be used */
		cdte.current_service_type = MC_SERVICE; /* TDY Initializer */

/**** Notify operator */

		call sys_log_ (SL_LOG_BEEP, "^a: Channel ^a dialed to Initializer ^[(^a.^a)^]", ME, cdte.name,
		     cdte.flags.access_control.slave_dial, cdte.user_name.person, cdte.user_name.project);

		call DIALIN_OK ();
		return;
	     end;

	if target_person_project ^= ""		/* check for null person.project qualifier */
	then do;					/* resolve this dial by person-project search */
		rq_person = before (target_person_project, ".");
						/* break up person.project */
		rq_project = after (target_person_project, ".");
		if ^convert_aliases (rq_person, rq_project)
		then do;
			call ABORT_DIALIN (as_error_table_$dialnotup, "");
			return;
		     end;
		find_person_project = "1"b;
	     end;
	else find_person_project = "0"b;

	if ^cdte.current_access_class_valid & cdte.flags.access_control.slave_dial
						/* we need an access class, and never got it!? */
	then do;
		call ABORT_DIALIN (as_error_table_$dialup_error,
		     "cdte.current_access_class_valid = ""0""b for channel at dial request time.");
		return;
	     end;

	used_privilege = "0"b;			/* set by next call if comm priv used */

/**** Implicit parameters are find_person_project,
      rq_person, rq_project, dial_qualifier, cdte, ute. ****/

	utep = find_dialable_process ();

	if utep = null
	then do;					/* not found in any user table */
		call ABORT_DIALIN (as_error_table_$dialnotup, "");
		return;				/* User control will give us another chance */
	     end;

	mcode = as_error_table_$dial_connect_msg;	/* Make up nice msg */
	date = date_time_$format ("system_date_time", anstbl.current_time, "system_zone", "system_lang");
	call convert_status_code_ (mcode, junk, format);	/* .. */
	call convert_access_class_$to_string_short (ute.process_authorization, server_authorization, code);
	if server_authorization = ""
	then call ioa_$rsnnl ("^a (^a.^a)", user_string, user_lth, ute.dial_qualifier, ute.person, ute.project);
	else call ioa_$rsnnl ("^a (^a.^a) (^a)", user_string, user_lth, ute.dial_qualifier, ute.person, ute.project,
		server_authorization);
	call ioa_$rs (format, buffer, i, cdte.current_terminal_type, cdte.tty_id_code, user_string, date);
	if cdte.service_type ^= FTP_SERVICE		/* for FTP, server will print out message */
	then call astty_$tty_force (cdtep, addr (buffer), i, code);
						/* write it out */
	if cdte.state < TTY_DIALED
	then do;
		call ABORT_DIALIN (error_table_$io_no_permission, "channel hungup");
		return;
	     end;

	cdte.process = utep;			/* Remember Owner */
	cdte.dialed_to_procid = ute.proc_id;		/* .. */
	cdte.dial_ev_chn = ute.dial_ev_chn;		/* .. */
	ute.ndialed_consoles = ute.ndialed_consoles + 1;

	call DIALIN_OK ();				/* report success */
	call connect_channel_to_user (DIAL_IN, used_privilege);
	P_code = 0;				/* we made it */
	return;
%page;
dial_rq:
     entry (a_request_ptr, a_asr_sender_ptr);

/**** This entry is called to handle the system-wide event channel provided
      for processes that wish to sign on of off as dial servers, or who
      wish to attach or release communications channels. */

/* parameters */

dcl     (a_request_ptr, a_asr_sender_ptr) ptr parameter;
dcl     1 sender_authorization aligned like aim_template;

	on any_other call as_any_other_handler_ (ME, NULL_PROC, REQUEST_RETURNS, REQUEST_RETURNS);

	call SETUP_REQUEST (code);
	if code ^= 0
	then return;

	request_type = UNKNOWN_RQ;			/* we'll set this later */

	if static_trace_sw
	then call trace_request ("dial_rq");

	if dial_server_request.flags.start
	then call start_dial_id_request;
	else if dial_server_request.flags.stop
	then call stop_dial_id_request;
	else if dial_server_request.flags.release_channel
	then call release_channel_request;
	else if dial_server_request.flags.privileged_attach
	then call privileged_attach_request;
	else if dial_server_request.flags.release_dial_id
	then call release_dial_id_request;
	else /* Didn't specify what was to be done. */
	     do;
		call sys_log_ (SL_LOG_SILENT,
		     "^a: Rejected unknown request from ^a.^a.  No request flags set in dial_server_request.", ME,
		     ute.person, ute.project);
		call SEND_ERROR_MESSAGE_AND_REJECT (error_table_$request_not_recognized);
	     end;

	goto REQUEST_RETURNS;
%page;
dial_out_rq:
     entry (a_request_ptr, a_asr_sender_ptr);

/**** This entry is called in reponse to a user-initiated request to
      regarding an autocall (dial_out) channel.  It handles dial_out
      requests as well as release requests. */

	on any_other call as_any_other_handler_ (ME, NULL_PROC, REQUEST_RETURNS, REQUEST_RETURNS);

	call SETUP_REQUEST (code);
	if code ^= 0
	then return;

	if dial_server_request.flags.release_channel
	then request_type = TERMINATE_DIAL_OUT_RQ;
	else request_type = DIAL_OUT_RQ;

	if static_trace_sw
	then call trace_request ("dial_out_rq");

	CAI.valid = FALSE;
	CAI.valid.user_validation_level = TRUE;		/* for auditing */
	CAI.user_validation_level = process_ring;

	call set_desired_channel;			/* check for starname, etc. */
	if reason_code ^= 0
	then call REJECT_CHANNEL_REQUEST (reason_code, reason);

	if dial_server_request.flags.release_channel
	then call terminate_dial_out_request ();
	else call dial_out_request ();

	goto REQUEST_RETURNS;
%page;
dial_term:
     entry (P_cdtep);

/**** This entry is called by dialup_ whenever a dialed console hangs up. */

	if as_data_$ansp = null
	then return;				/* Not initialized */
	ansp = as_data_$ansp;

	cdtep = P_cdtep;
	reason_code = 0;

	if static_trace_sw
	then call trace ("(dial_term) Channel ^a", cdte.name);

	reason = cdte.name;

	chn = cdte.dial_ev_chn;			/* Nice local copies */
	process_id = cdte.dialed_to_procid;		/* ... */

	if process_id = anstbl.as_procid
	then do;					/* Slaved to initializer? */
		reason = "hangup";
		CAI.channel_name = cdte.name;
		CAI.valid = FALSE;
		CAI.valid.service_info = TRUE;
		CAI.service_info = SERVICE_TYPE (cdte.current_service_type);
		CAI.valid.access_class = TRUE;
		if cdte.dialup_flags.current_access_class_valid
		then CAI.access_class = cdte.current_access_class (1);
		else CAI.access_class = get_process_access_class_ ();
		CAI.valid.access_class_range = TRUE;
		CAI.access_class_range = cdte.access_class;
		utep = cdte.process;
		call as_access_audit_$channel (cdtep, null, utep, AS_AUDIT_CHANNEL_DETACH, addr (CAI), reason);
	     end;
	else do;
		utep = cdte.process;		/* Find owner */
		if utep ^= null
		then do;				/* Ignore if terminal did "slave" and then hung up. */
			if ute.proc_id ^= cdte.dialed_to_procid
			then /* Race condition in logout.. note */
			     call sys_log_ (SL_LOG_SILENT,
				"dial_ctl_: Channel ^a (^a, ^a) hung up on missing process ^w", cdte.name,
				SERVICE_TYPE (cdte.current_service_type),
				display_access_class_ (cdte.current_access_class (1)), cdte.dialed_to_procid);
			else do;
				call device_acct_$off ((cdte.charge_type), cdte.name, utep);
						/* Stop charging for device */

				call decrement_ndialed;
						/* reduce ate.ndialed_consoles */
				call SEND_CHANNEL_MESSAGE (JUST_HUNGUP);
				reason = "hangup";

				CAI.channel_name = cdte.name;
				CAI.valid = FALSE;
				CAI.valid.service_info = TRUE;
				CAI.service_info = SERVICE_TYPE (cdte.current_service_type);
				CAI.valid.access_class = TRUE;
				if cdte.dialup_flags.current_access_class_valid
				then CAI.access_class = cdte.current_access_class (1);
				else CAI.access_class = ute.process_authorization;
				CAI.valid.access_class_range = TRUE;
				CAI.access_class_range = cdte.access_class;
				CAI.valid.user_validation_level = TRUE;
				CAI.user_validation_level = process_ring;
				call as_access_audit_$channel (cdtep, null, utep, AS_AUDIT_CHANNEL_DETACH,
				     addr (CAI), reason);
			     end;
		     end;
	     end;

	call meter_dut;				/* metering dialed_up_time */

	if cdte.flags.access_control.slave_dial & cdte.service_type = ANS_SERVICE
	then /* authenticated */
	     call lg_ctl_$logout_channel (cdtep, "hangup");
						/* logout channel */
	cdte.current_service_type = cdte.service_type;	/* Make channel normal again. */
	cdte.dialed_to_procid = "0"b;
	cdte.dial_ev_chn = 0;
	cdte.process = null;

/* Ensure the channel's current access class is reset to the CDT-specified
   default (either a range or single class). */

	call asu_$reset_access_class (cdtep);

	if cdte.state ^= TTY_MASKED
	then call asu_$asu_listen (cdtep, code);
	else cdte.in_use = NOW_HUNG_UP;

	return;
%page;
dial_broom:
     entry (uptr, funct);

/**** This entry is called whenever the master process is destroyed. */

dcl     uptr ptr parameter,				/* Ptr to ate of master process dying */
        funct char (8) aligned parameter;		/* Reason why we are sweeping */

	utep = uptr;
	if as_data_$ansp = null
	then return;
	ansp = as_data_$ansp;

	reason_code = 0;
	reason = "";

	if static_trace_sw
	then call trace ("(dial_broom) User ^a.^a function ^a.", ute.person, ute.project, funct);

	if ute.dial_qualifier ^= ""
	then do;					/* report when a user stops serving */
		DSI.server_ring = ute.dial_server_ring;
		DSI.dial_qualifier = ute.dial_qualifier;
		DSI.privileged = ute.privileged_dial_server;
		DSI.registered = ute.registered_dial_server;
		added_info = funct;
		call as_access_audit_$dialid (utep, AS_AUDIT_DIALID_STOP, addr (DSI), added_info);
		ute.dial_qualifier = "";		/* don't let any more come thru */
	     end;

	ute.registered_dial_server = "0"b;		/* reset to default value */
	ute.privileged_dial_server = "0"b;
	ute.dial_server_ring = 7;

	if ute.ndialed_consoles = 0			/* dont waste time searching the table */
	then return;				/* if there aren't going to be any entries */

	if funct = "new_proc"
	then word = "dialgrab";
	else if substr (funct, 1, 4) = "term"
	then word = "dialgrab";
	else word = "dialhang";

	if word = "dialgrab"
	then mcode = as_error_table_$dialagain;
	else mcode = as_error_table_$dialdied;

	if funct = "stopdial"
	then do;
		reason = "dialid shut off";
		process_destroyed_flag = FALSE;	/* shutoff_dials request */
	     end;
	else do;
		reason = word;			/* for log message */
		process_destroyed_flag = TRUE;
	     end;

	do i = 1 to scdtp -> cdt.current_size;		/* was somebody */
	     cdtep = addr (scdtp -> cdt.cdt_entry (i));
	     if cdte.in_use > NOW_FREE
	     then if cdte.dialed_to_procid = ute.proc_id
		then call release_channel ("1"b, "0"b, (cdte.current_service_type = TANDD_SERVICE), reason);
	end;

	if anstbl.login_server_present
	then call uc_cleanup_network_dials_ (ute.proc_id, process_destroyed_flag, (0));
	ute.ndialed_consoles = 0;			/* we have done our job */
	return;
%page;

REQUEST_RETURNS:					/* return point for a dial_ctl_ request */
	return;

finish_priv_attach:
     entry (a_cdtep);

/**** This entry is called by dialup_ when the channel which has been
      priv_attach'ed finally dials up.  This will only be invoked when
      the channel was not dialed up when the priv_attach was initiated.

      /* parameters */

dcl     a_cdtep ptr parameter;

/* program */

	ansp = as_data_$ansp;
	request_type = PRIV_ATTACH_CHN_RQ;
	cdtep = a_cdtep;
	if static_trace_sw
	then call trace ("(fin_priv_attach) Channel ^a", cdte.name);
	utep = cdte.process;			/* Find Owner */
	reason_code = 0;
	reason = cdte.name;

	process_id = cdte.dialed_to_procid;		/* Initialize on off chance it's used */
	chn = cdte.dial_ev_chn;			/* ... */
	if utep = null
	then do;					/* can't happen unless bug */
woops1:
		call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Can't find process ^12.3b", cdte.dialed_to_procid);
		return;
	     end;
	else if ute.proc_id ^= cdte.dialed_to_procid
	then go to woops1;

/**** Recheck the access. If the channel dialed up, and supplied
      an access class, it might be incompatable with the process. */

	if ^aim_check_process_and_channel (utep, (cdte.dial_ctl_ring), cdte.dial_rq_privileged, PRIV_ATTACH,
	     used_privilege)			/* use ring saved in cdte. */
	then do;
		added_info = "Access check failed after slave dialup";
		call fake_connect_channel_to_user (PRIV_ATTACH, added_info);
		call astty_$tty_order (cdtep, "hangup", null, (0));
		return;
	     end;

	if cdte.service_type ^= ANS_SERVICE
	then do;					/* no metering of login lines */
		cdte.dialup_time = anstbl.current_time;
		cdte.n_logins = cdte.n_logins + 1;
	     end;
	call set_terminal_type;
	call connect_channel_to_user (PRIV_ATTACH, used_privilege);
	return;

continue_tandd_attach:
     entry (a_cdtep);

/**** This entry is called by dialup_ when a channel which is being
      tandd_attach'd hangs up.  The attaching process has been waiting
      for the line to become hung up all this time. */

	request_type = TANDD_ATTACH_CHN_RQ;

	cdtep = a_cdtep;

	if static_trace_sw
	then call trace ("(continue_tandd_attach) Channel ^a", cdte.name);

	reason_code = 0;
	reason = cdte.name;

	call astty_$tty_order (cdtep, "tandd_attach", null, code);
	if code = -1
	then /* Translate silly error code */
	     code = error_table_$io_no_permission;

	if code ^= 0				/* we'd better try to tell him now */
	then do;
		added_info = "tandd_attach control order failed";
		call fake_connect_channel_to_user (T_AND_D, added_info);
		call astty_$tty_order (cdtep, "hangup", null (), (0));
	     end;

	else cdte.tra_vec = WAIT_FIN_TANDD_ATTACH;	/* channel should now signal dialup, */
	return;					/* at which point we will hand it to user */

finish_tandd_attach:
     entry (a_cdtep);

/**** This entry is called by dialup_ when a terminal which has been
      tandd_attach'd simulates a dialup. */

	request_type = TANDD_ATTACH_CHN_RQ;
	cdtep = a_cdtep;

	if static_trace_sw
	then call trace ("(finish_tandd_attach) Channel ^a", cdte.name);

	utep = cdte.process;			/* Find Owner */
	process_id = cdte.dialed_to_procid;		/* Initialize on off chance it's used */
	chn = cdte.dial_ev_chn;			/* ... */
	if utep = null
	then do;					/* can't happen unless bug */
tandd_error:
		call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Can't find process ^12.3b", cdte.dialed_to_procid);
		return;
	     end;
	else if ute.proc_id ^= cdte.dialed_to_procid
	then go to tandd_error;
	call connect_channel_to_user (T_AND_D, "0"b);
	return;
%page;
finish_dial_out:
     entry (a_cdtep);

/**** This entry is called by dialup_ when a wakeup is received indicating
      completion (successful or otherwise) of a dial_out control order
      previously issued for the channel. */

	request_type = DIAL_OUT_RQ;

	ansp = as_data_$ansp;
	cdtep = a_cdtep;

	if static_trace_sw
	then call trace ("(finish_dial_out) Channel ^a", cdte.name);
	reason_code = 0;
	reason = cdte.name;

	utep = cdte.process;			/* get ate pointer */
	process_id = cdte.dialed_to_procid;		/* Initialize on off chance it's used */
	chn = cdte.dial_ev_chn;			/* ... */
	if utep = null ()
	then do;
whoops2:
		call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Can't find process ^12.3b", cdte.dialed_to_procid);
		return;
	     end;
	else if ute.proc_id ^= cdte.dialed_to_procid
	then go to whoops2;

	call astty_$tty_order (cdtep, "dial_out_status", null (), code);
	if code ^= 0
	then call DIAL_OUT_CHANNEL_ERROR ();		/* Doesn't return */
	cdte.in_use = NOW_DIALED_OUT;			/* record that channel is dialed up */
	call set_terminal_type;
	term_info.version = terminal_info_version;
	call astty_$tty_order (cdtep, "terminal_info", addr (term_info), code);
	if code ^= 0
	then call DIAL_OUT_CHANNEL_ERROR ();		/* doesn't return */
	cdte.current_terminal_type = term_info.term_type; /* Store info in CDTE for this channel */
	cdte.tty_id_code = term_info.id;		/* .. */
	if cdte.flags.autobaud
	then /* if it can change, then save it */
	     cdte.baud_rate = term_info.baud_rate;

	cdte.n_logins = cdte.n_logins + 1;
	cdte.dialup_time = anstbl.current_time;
	call connect_channel_to_user (DIAL_OUT, dial_out_used_privilege);
	return;

trace_on:
     entry;

	static_trace_sw = "1"b;
	call sys_log_ (SL_LOG, "dial_ctl_: Tracing turned on.");
	return;

trace_off:
     entry;

	static_trace_sw = "0"b;
	call sys_log_ (SL_LOG, "dial_ctl_: Tracing turned off.");
	return;
%page;
start_dial_id_request:
     procedure ();

/**** Internal procedure to handle requests to sign on as dial servers */

	request_type = START_DIAL_ID_RQ;

/**** Set up info for auditing record */
	DSI.dial_qualifier = dial_server_request.dial_qualifier;
	DSI.server_ring = process_ring;
	DSI.privileged = dial_server_request.flags.privileged_server;
	DSI.registered = dial_server_request.flags.registered_server;

	if ^(ute.at.dialok)
	then call REJECT_DIALID_REQUEST (error_table_$no_dialok, "User lacks dialok attribute");

	if dial_server_request.flags.privileged_server & ^(sender_authorization.privileges.comm | (process_ring = 1))
	then do;
		call ioa_$rsnnl ("process lacks comm priv for privileged service of ^a.", reason, (0),
		     dial_server_request.dial_qualifier);
		call REJECT_DIALID_REQUEST (error_table_$ai_restricted, reason);
	     end;

	if ute.dial_qualifier ^= ""
	     &
	     /* active and not a request for the same thing? */ (ute.dial_qualifier
	     ^= dial_server_request.dial_qualifier
	     | ute.registered_dial_server ^= dial_server_request.registered_server)
	then do;					/* no can do */
		call ioa_$rsnnl ("process already serving ^a^[ (registered)^], can't serve ^a.", reason, (0),
		     ute.dial_qualifier, ute.registered_dial_server, dial_server_request.dial_qualifier);
		call REJECT_DIALID_REQUEST (error_table_$dial_active, reason);
	     end;
	if dial_server_request.flags.registered_server
	then do;
		if ^check_acs ("dial." || dial_server_request.dial_qualifier, process_group_id, process_ring)
		then do;
			call ioa_$rsnnl ("process lacks access to registered dial acs for ^a.", reason, (0),
			     dial_server_request.dial_qualifier);
			if reason_code = error_table_$noentry
			then reason_code = error_table_$name_not_found;
			call REJECT_DIALID_REQUEST (reason_code, reason);
		     end;
		if ^aim_check_registered_server_namedup (reason_code)
		then do;
			call ioa_$rsnnl ("another process is registered dial server for ^a.", reason, (0),
			     dial_server_request.dial_qualifier);
			call REJECT_DIALID_REQUEST (reason_code, reason);
		     end;
		ute.registered_dial_server = "1"b;
	     end;

	else /* request is for non-registered qualifier */
	     ute.registered_dial_server = "0"b;
	ute.privileged_dial_server = dial_server_request.privileged_server;

	ute.dial_ev_chn = chn;			/* Save dial event channel */
	ute.dial_qualifier = dial_server_request.dial_qualifier;
	ute.dial_server_ring = process_ring;

	if ute.registered_dial_server
	then do;
		added_info = "(registered";
		if ute.privileged_dial_server
		then added_info = rtrim (added_info) || " privileged";
		added_info = rtrim (added_info) || ")";
	     end;
	else if ute.privileged_dial_server
	then added_info = "(privileged)";
	else added_info = "";

	call as_access_audit_$dialid (utep, AS_AUDIT_DIALID_START, addr (DSI), added_info);

	call SEND_CONTROL_MESSAGE (bit (fixed (ute.ndialed_consoles, 15), 15));
	return;
     end start_dial_id_request;
%page;
stop_dial_id_request:
     procedure;

/**** Request to stop serving a dial id and to disconnect all channels
      dialed to this process. */

	request_type = STOP_DIAL_ID_RQ;

	DSI.dial_qualifier = dial_server_request.dial_qualifier;
	DSI.server_ring = ute.dial_server_ring;
	DSI.registered = ute.registered_dial_server;
	DSI.privileged = ute.privileged_dial_server;

	if ^(ute.at.dialok)
	then call REJECT_DIALID_REQUEST (error_table_$no_dialok, "User lacks dialok attribute");

	if ute.dial_qualifier ^= ""
	then /* actively serving anything? */
	     if ((ute.dial_qualifier = dial_server_request.dial_qualifier) | (dial_server_request.dial_qualifier = ""))
	     then do;
		     call dial_broom (utep, "stopdial");/* Remove all slaves */
		     call SEND_CONTROL_MESSAGE (""b);
		end;
	     else do;
		     reason = "Dial id not in use by this process";
		     call REJECT_DIALID_REQUEST (0, reason);
		end;
	else do;
		reason = "No dial id in use by this process";
		call REJECT_DIALID_REQUEST (0, reason);
	     end;
	call SEND_CONTROL_MESSAGE (bit (fixed (ute.ndialed_consoles, 15), 15));
     end stop_dial_id_request;
%page;
release_dial_id_request:
     procedure;

/**** Release a dial id such that future attempts to dial a console to this
      dial id will fail.  All consoles already dialed to this dial id, however
      will remain dialed. */

	request_type = RELEASE_DIAL_ID_RQ;

	DSI.dial_qualifier = dial_server_request.dial_qualifier;
	DSI.server_ring = ute.dial_server_ring;
	DSI.privileged = ute.privileged_dial_server;
	DSI.registered = ute.registered_dial_server;

	if ^(ute.at.dialok)
	then call REJECT_DIALID_REQUEST (error_table_$no_dialok, "User lacks dialok attribute");

	if ute.dial_qualifier ^= ""
	then /* actively serving anything? */
	     if ((ute.dial_qualifier = dial_server_request.dial_qualifier) | (dial_server_request.dial_qualifier = ""))
	     then do;
		     added_info = "dialid released";

		     if ute.ndialed_consoles ^= 0
		     then call ioa_$rsnnl ("^a (keeping ^d dialed console^[s^])", added_info, (0), added_info,
			     ute.ndialed_consoles, (ute.ndialed_consoles ^= 1));

		     call as_access_audit_$dialid (utep, AS_AUDIT_DIALID_STOP, addr (DSI), added_info);
		     ute.dial_qualifier = "";		/* back to default */
		     ute.registered_dial_server = "0"b; /* also default */
		end;
	     else do;
		     added_info = "Dial id not in use by this process";
		     call REJECT_DIALID_REQUEST (0, reason);
		end;
	else do;
		added_info = "No dial id in use by this process";
		call REJECT_DIALID_REQUEST (0, reason);
	     end;

	call SEND_CONTROL_MESSAGE (bit (fixed (ute.ndialed_consoles, 15), 15));
	return;
     end release_dial_id_request;
%page;
release_channel_request:
     procedure;					/* Request to release a channel */

	request_type = RELEASE_CHN_RQ;

	CAI.channel_name = dial_server_request.channel_name;
						/* for auditing */
	CAI.valid = FALSE;
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = process_ring;

	if ^(ute.at.dialok)
	then call REJECT_CHANNEL_REQUEST (error_table_$no_dialok, "User lacks dialok attribute");

	if dial_server_request.channel_name = ""
	then do;					/* frequent problem */
		reason = "Null channel name specified";
		call REJECT_CHANNEL_REQUEST (0, reason);
	     end;

	call find_cdte;				/* try to find channel */
	if cdtep = null
	then do;					/* Channel doesn't exist.  Error code set by find_cdte. */
		call ioa_$rsnnl ("Channel ^a not found.", reason, (0), dial_server_request.channel_name);
		call REJECT_CHANNEL_REQUEST (reason_code, reason);
	     end;

	if cdte.dialed_to_procid ^= process_id
	then do;					/* Channel not his */
		reason = "Channel not attached to this process";
		call REJECT_CHANNEL_REQUEST (error_table_$io_no_permission, reason);
	     end;

	call decrement_ndialed;			/* one less... */
	if cdte.current_service_type = TANDD_SERVICE	/* was this in T & D service? */
	then suppress_listen = dial_server_request.flags.no_listen;
						/* then he's allowed to specify this */
	else suppress_listen = "0"b;
	call release_channel ("0"b, dial_server_request.flags.no_hangup, suppress_listen, "release");
						/* actual release */
	call SEND_CONTROL_MESSAGE (REQUEST_GRANTED);
	return;
     end release_channel_request;
%page;
privileged_attach_request:
     procedure ();

	if dial_server_request.flags.tandd_attach
	then request_type = TANDD_ATTACH_CHN_RQ;
	else request_type = PRIV_ATTACH_CHN_RQ;

	CAI.channel_name = dial_server_request.channel_name;
	CAI.valid = FALSE;
	CAI.valid.user_validation_level = TRUE;		/* for auditing */
	CAI.user_validation_level = process_ring;

	if ^(ute.at.dialok)
	then call REJECT_CHANNEL_REQUEST (error_table_$no_dialok, "User lacks dialok attribute");

	call set_desired_channel;
	if reason_code ^= 0
	then call REJECT_CHANNEL_REQUEST (reason_code, reason);

	reason = dial_server_request.channel_name;	/* assume the worst */

	if dial_server_request.flags.tandd_attach
	then call look_for_channel (T_AND_D);		/* and check access */
	else call look_for_channel (PRIV_ATTACH);

	CAI.channel_name = cdte.name;			/* update this in case starname was used */
	CAI.valid.access_class = cdte.dialup_flags.current_access_class_valid;
	CAI.access_class = cdte.current_access_class (1);
	CAI.valid.access_class_range = TRUE;
	CAI.access_class_range = cdte.access_class;

	if dial_server_request.tandd_attach		/* both acs's needed */
	then do;
		call up_sysctl_$check_acs ("tandd.acs", process_group_id, (process_ring), mode, code);
		if code ^= 0 | ((mode & RW_ACCESS) ^= RW_ACCESS)
		then do;
			if code ^= 0
			then call sys_log_$error_log (SL_LOG_SILENT, code,
				"dial_ctl_: Could not check access to ^a>tandd.acs for ^a.", as_data_$acsdir,
				process_group_id);
			call ioa_$rsnnl ("rw access is required to ^a", reason, (0),
			     pathname_ (as_data_$acsdir, "tandd.acs"));
			call REJECT_CHANNEL_REQUEST (error_table_$insufficient_access, reason);
		     end;
	     end;

	cdte.process = utep;			/* remember owner */
	cdte.dial_ev_chn = chn;			/* .. */
	cdte.dialed_to_procid = ute.proc_id;		/* .. */
	cdte.dial_ctl_ring = process_ring;		/* remember for FIN_PRIV_ATTACH access check. */
	cdte.dial_rq_privileged = sender_authorization.privileges.comm;
	ute.ndialed_consoles = ute.ndialed_consoles + 1;

	if ^dial_server_request.tandd_attach
	then if cdte.service_type ^= ANS_SERVICE
	     then /* no metering for login lines */
		cdte.n_dialups = cdte.n_dialups + 1;

	code = 0;

	call SEND_CONTROL_MESSAGE (REQUEST_GRANTED);

	if dial_server_request.flags.tandd_attach
	then do;
		if cdte.state ^= TTY_HUNG		/* have to make it stop listening */
		then do;
			if static_trace_sw
			then call trace ("(priv_attach) Hanging up ^a for T&D", cdte.name);
			call astty_$tty_order (cdtep, "hangup", null, (0));
			cdte.tra_vec = WAIT_TANDD_HANGUP;
			goto REQUEST_RETURNS;
		     end;

		else do;
			if static_trace_sw
			then call trace ("(priv_attach) ^a hung up, tandd attaching.", cdte.name);
			call astty_$tty_order (cdtep, "tandd_attach", null, code);
			if code ^= 0
			then do;
				call sys_log_$error_log (SL_LOG_SILENT, code,
				     "^a: Issuing tandd_attach control order for channel ^a.", ME, cdte.name);
				added_info = "tandd_attach control order failed";
				call fake_connect_channel_to_user (T_AND_D, added_info);
				call astty_$tty_order (cdtep, "hangup", null (), (0));
				goto REQUEST_RETURNS;
			     end;

			cdte.tra_vec = WAIT_FIN_TANDD_ATTACH;
			goto REQUEST_RETURNS;
		     end;
	     end;
	else do;
		if cdte.state = TTY_DIALED
		then do;
			if cdte.service_type ^= ANS_SERVICE
			then do;			/* not 'slave' pre-access */
				cdte.dialup_time = anstbl.current_time;
				cdte.n_logins = cdte.n_logins + 1;
			     end;
			call set_terminal_type;
			call connect_channel_to_user (PRIV_ATTACH, used_privilege);
						/* Is dialed, give it away */
		     end;
		else cdte.tra_vec = WAIT_FIN_PRIV_ATTACH;
						/* Wait for it to dialup */
	     end;

	return;
     end privileged_attach_request;
%page;
dial_out_request:
     procedure ();

/**** User request to dial out on a specified channel. */

	CAI.channel_name = dial_server_request.channel_name;
	CAI.valid = FALSE;
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = process_ring;

	if ^(ute.at.dialok)				/* Must have the dialok attribute */
	then call REJECT_CHANNEL_REQUEST (error_table_$no_dialok, "User does not have dialok attribute");

	call set_requested_channel_access_class ();	/* find an appropriate channel, access-class wise */
	if reason_code ^= 0
	then call REJECT_CHANNEL_REQUEST (reason_code, reason);

	dial_out_used_privilege = used_privilege;	/* save the global since look_for_channel will zero it */
	phone_data = rtrim (dial_server_request.dial_out_destination);

	call look_for_channel (DIAL_OUT);		/* star scan for likely channel.  It will reject request if none found. */

	CAI.channel_name = cdte.name;			/* update in case starname was used */
	CAI.valid.access_class = cdte.dialup_flags.current_access_class_valid;
	CAI.access_class = cdte.current_access_class (1);
	CAI.valid.access_class_range = TRUE;
	CAI.access_class_range = cdte.access_class;

/**** The one place we SPECIFY the access class with a set order! */

	call set_dial_out_channel_access_class (reason_code);
	if reason_code ^= 0
	then call REJECT_CHANNEL_REQUEST (reason_code, "set_required_access_class failed");

	cdte.in_use = NOW_DIALING;			/* remember what we're doing ... */
	cdte.tra_vec = WAIT_DIAL_OUT;			/* and what to do next */

	CAI.valid.service_info = TRUE;
	CAI.service_info = phone_data;
	if dial_out_used_privilege
	then reason = "using comm privilege";
	else reason = "";

	call as_access_audit_$channel (cdtep, null, utep, AS_AUDIT_CHANNEL_DIALOUT, addr (CAI), reason);

	call astty_$tty_order (cdtep, "dial_out", addr (phone_data), code);
						/* start dialing */
	if code ^= 0
	then do;
		if code = -1
		then code = error_table_$io_no_permission;
		call sys_log_$error_log (0, code, ME, "after dial_out order (^a for ^a.^a).", cdte.name, ute.person,
		     ute.project);
		cdte.in_use = NOW_HUNG_UP;
		cdte.tra_vec = WAIT_SLAVE_REQUEST;
		call REJECT_CHANNEL_REQUEST (error_table_$order_error, "dial_out control order failed");
	     end;

	cdte.process = utep;			/*  looks like we can give it away... */
	cdte.dial_ctl_ring = process_ring;		/* record ring of dialer */
	cdte.dialed_to_procid = ute.proc_id;		/* .. */
	cdte.dial_ev_chn = chn;			/* remember IPC channel in request */
	cdte.n_dialups = cdte.n_dialups + 1;		/* keep track of how often we try dialing */
	ute.ndialed_consoles = ute.ndialed_consoles + 1;

	call SEND_CONTROL_MESSAGE (REQUEST_GRANTED);
	return;

     end dial_out_request;
%page;
terminate_dial_out_request:
     procedure ();

/**** User request to detach a dialed out channel. */

	CAI.channel_name = dial_server_request.channel_name;
	CAI.valid = FALSE;
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = process_ring;

	if ^(ute.at.dialok)				/* Must have the dialok attribute */
	then call REJECT_CHANNEL_REQUEST (error_table_$no_dialok, "User does not have dialok attribute");

	if dial_server_request.channel_name = ""
	then do;
		reason = "Invalid channel specified";
		call REJECT_CHANNEL_REQUEST (0, reason);
	     end;

	call find_cdte;				/* find the channel */
	if cdtep = null
	then do;					/* No such channel.  Error code set by find_cdte. */
		call ioa_$rsnnl ("Channel ^a does not exist.", reason, (0), dial_server_request.channel_name);
		call REJECT_CHANNEL_REQUEST (reason_code, reason);
	     end;

	CAI.valid.access_class = cdte.dialup_flags.current_access_class_valid;
	CAI.access_class = cdte.current_access_class (1);
	CAI.valid.access_class_range = TRUE;
	CAI.access_class_range = cdte.access_class;

	if cdte.current_service_type ^= DIAL_OUT_SERVICE
	then do;					/* Channel not a dialed out */
		reason = "Channel not currently dialed out";
		call REJECT_CHANNEL_REQUEST (error_table_$action_not_performed, reason);
	     end;

	if cdte.dialed_to_procid ^= ute.proc_id
	then do;					/* Channel not his */
		reason = "Channel not currently dialed out for this process";
		call REJECT_CHANNEL_REQUEST (error_table_$io_no_permission, reason);
	     end;

	cdte.tra_vec = WAIT_DIAL_RELEASE;		/* make sure we  do the right thing */
	cdte.dial_ev_chn = chn;			/* user's dial_manager_ is blocked on this channel */
						/* which MIGHT be different than cdte.dial_ev_chn */

	call asu_$reset_access_class (cdtep);
	call astty_$tty_order (cdtep, "hangup", null, (0));
						/* drop connection to channel */
	call SEND_CONTROL_MESSAGE (REQUEST_GRANTED);
	return;
     end terminate_dial_out_request;
%page;
connect_channel_to_user:
     procedure (P_attachment_type, report_privilege);

/**** connect_channel_to_user vs fake_connect_channel_to_user:
      In the fake case, we want to issue a hangup.  It's simpler all around
      if we can just pretend that we gave the channel to the user, but don't
      actually tell the dim to new_proc.  We do everything else, including
      sending the dialed-up wakeup.  (The user 'has' to be prepared for
      a dialup wakeup resulting in io_no_permission because the channel
      has already hung up by the time he acts on the dialup.) */

dcl     P_attachment_type fixed bin (17) parameter;
dcl     P_added_info char (*) parameter;
dcl     fake_connect bit (1) aligned;
dcl     report_privilege bit (1) aligned parameter;

/* connect_channel_to_user: procedure (); */

	fake_connect = "0"b;
	go to connect_join;

fake_connect_channel_to_user:
     entry (P_attachment_type, P_added_info);

	fake_connect = "1"b;

connect_join:
	if P_attachment_type = DIAL_IN
	then cdte.current_service_type = DIAL_SERVICE;
	else if P_attachment_type = T_AND_D
	then do;
		cdte.current_service_type = TANDD_SERVICE;
		cdte.tra_vec = WAIT_DISCARD_WAKEUPS;
		cdte.in_use = NOW_HUNG_UP;
	     end;

	if cdte.current_service_type ^= TANDD_SERVICE
	then do;
		cdte.tra_vec = WAIT_DIAL_RELEASE;	/* Catch terminal when it hangs up */
		cdte.in_use = NOW_DIALED;		/* record the fact that we have channel */
	     end;

	call astty_$tty_order (cdtep, "copy_meters", null (), (0));

/* Set up for auditing */

	CAI.channel_name = cdte.name;
	CAI.valid = FALSE;
	CAI.valid.service_info = TRUE;
	CAI.service_info = ATTACHMENT_TYPES (P_attachment_type);
	CAI.valid.access_class = cdte.dialup_flags.current_access_class_valid;
	CAI.access_class = cdte.current_access_class (1);
	CAI.valid.access_class_range = TRUE;
	CAI.access_class_range = cdte.access_class;
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = process_ring;

	if ^fake_connect
	then do;					/* we're really giving it to the user */

		call astty_$tty_new_proc (cdtep, ute.proc_id, code);
						/* give channel to user */
		if code = 0
		then do;
			if report_privilege
			then added_info = "using comm privilege";
			else added_info = "";

			call as_access_audit_$channel (cdtep, null, utep, AS_AUDIT_CHANNEL_ATTACH, addr (CAI),
			     added_info);
		     end;
		else call sys_log_$error_log (SL_LOG_SILENT, code, ME,
			"call to astty_$tty_new_proc of ^a for ^a.^a failed", cdte.name, ute.person, ute.project);
	     end;
	else /* audit denied attachment */
	     call as_access_audit_$channel (cdtep, null, utep, -AS_AUDIT_CHANNEL_ATTACH, addr (CAI), P_added_info);

/**** Start charging for attached device */

	call device_acct_$on ((cdte.charge_type), cdte.name, utep);

/**** Notify user */

	call SEND_CHANNEL_MESSAGE (JUST_DIALED);
	return;

     end connect_channel_to_user;
%page;
look_for_channel:
     procedure (operation);

/**** Internal procedure to scan cdt for channels that meet requirements
      such as star name match, baud desired, etc. */

dcl     found bit (1) aligned;
dcl     found_device_available bit (1) aligned;
dcl     found_in_cdt bit (1) aligned;
dcl     found_good_access bit (1) aligned;
dcl     found_good_attributes bit (1) aligned;
dcl     operation fixed bin;

	cdtep = null ();
	found, found_device_available, found_in_cdt, found_good_access, found_good_attributes = "0"b;

	reason_code = 0;

	do i = 1 to scdtp -> cdt.current_size while (^found);
	     cdtep = addr (scdtp -> cdt.cdt_entry (i));
	     found = cdte_matches_desired ();		/* try for match */
	     found_in_cdt = found_in_cdt | found;	/* remember if it were ever there */
	     if found
	     then do;				/* keep checking */
		     if dial_server_request.baud_rate ^= -1
		     then /* any baud_rate, or ... */
			if dial_server_request.baud_rate ^= cdte.baud_rate
			then found = "0"b;
		     if dial_server_request.line_type >= lbound (line_types, 1)
		     then /* any line type, or ... */
			if dial_server_request.line_type ^= cdte.line_type
			then found = "0"b;
		     found_good_attributes = found_good_attributes | found;
		end;
	     if found
	     then if dial_server_request.flags.privileged_attach
		then found = check_priv_attach_access ();
		else found = check_dial_access ();
	     found_device_available = found_device_available | found;
	     if found
	     then found =
		     access_check_channel_and_process (utep, process_ring, sender_authorization.privileges.comm,
		     operation, used_privilege);
	     found_good_access = found_good_access | found;
	end;

	if ^found
	then do;					/* need more codes */
		cdtep = null ();			/* for auditing */
		if star_channel_name | reason_code = 0
		then /* if non-star channel and have error code, keep it */
		     if ^found_in_cdt
		     then reason_code = error_table_$resource_unknown;
		     else if ^found_good_attributes
		     then reason_code = error_table_$resource_unavailable;
		     else if ^found_device_available
		     then reason_code = error_table_$resource_unavailable;
		     else if ^found_good_access
		     then reason_code = error_table_$insufficient_access;
		     else if reason_code = 0
		     then reason_code = error_table_$resource_unavailable;
		call REJECT_CHANNEL_REQUEST (reason_code, desired_channel);
	     end;
     end look_for_channel;
%page;
set_terminal_type:
     procedure ();

/**** Procedure to set a terminal type */

dcl     code fixed bin (35);
dcl     tab_string char (512) var;
dcl     modes_string char (512);

	if cdte.initial_terminal_type = ""
	then return;
	if cdte.initial_terminal_type = low (length (cdte.initial_terminal_type))
	then return;
	sttip = addr (set_type_info);
	set_term_type_info.version = stti_version_1;
	set_term_type_info.name = cdte.initial_terminal_type;
	string (set_term_type_info.flags) = "0"b;
	call astty_$tty_order (cdtep, "set_term_type", sttip, code);
	if code ^= 0
	then return;

	cdte.current_terminal_type = set_term_type_info.name;

	call ttt_info_$initial_string (cdte.current_terminal_type, tab_string, code);
	if code ^= 0
	then go to end_initial_string;
	if length (tab_string) ^= 0
	then do;
		call astty_$tty_changemode (cdtep, "rawo", code);
		if code ^= 0
		then go to end_initial_string;
		call astty_$tty_force (cdtep, addrel (addr (tab_string), 1), length (tab_string), code);
	     end;
end_initial_string:
	call ttt_info_$modes (cdte.current_terminal_type, modes_string, code);
	if code ^= 0
	then return;
	call astty_$tty_changemode (cdtep, "force,init," || rtrim (modes_string), code);
	return;

     end set_terminal_type;
%page;
release_channel:
     procedure (master_destroyed, suppress_hangup, suppress_listen, P_reason);

/**** Procedure to release a channel that was dialed to a dial server
      process */

dcl     master_destroyed bit (1);
dcl     suppress_hangup bit (1);
dcl     suppress_listen bit (1);
dcl     was_tandd bit (1);
dcl     P_reason char (*) parameter;			/* reason we are detaching channel */

	if cdte.current_service_type = DIAL_SERVICE & master_destroyed
	then call asu_$write_chn_message (cdtep, mcode, junk, code);

	call astty_$tty_detach (cdtep, 0, code);	/* Take channel away from user */
	if code ^= 0
	then call sys_log_$error_log (0, code, ME, "Attempting to detach ^a from ^a.^a.", cdte.name, ute.person,
		ute.project);
	else do;
		call ioa_$rsnnl ("^a ^[(without hangup)^]^[(without listen)^]", added_info, (0), P_reason,
		     suppress_hangup, suppress_listen);

		CAI.channel_name = cdte.name;
		CAI.valid = FALSE;
		CAI.valid.service_info = TRUE;
		CAI.service_info = SERVICE_TYPE (cdte.current_service_type);
		CAI.valid.access_class = cdte.dialup_flags.current_access_class_valid;
		CAI.access_class = cdte.current_access_class (1);
		CAI.valid.access_class_range = TRUE;
		CAI.access_class_range = cdte.access_class;
		CAI.valid.user_validation_level = TRUE;
		CAI.user_validation_level = process_ring;
		call as_access_audit_$channel (cdtep, null, utep, AS_AUDIT_CHANNEL_DETACH, addr (CAI), added_info);
	     end;

	call device_acct_$off ((cdte.charge_type), cdte.name, utep);
	call meter_dut ();				/* meter dialed_up_time */
	call asu_$reset_access_class (cdtep);		/* Place back in known state */

	if cdte.current_service_type = TANDD_SERVICE	/* restore correct service type */
	then do;
		if suppress_listen			/* channel out of service for the moment */
		then cdte.current_service_type = INACTIVE;
		else cdte.current_service_type = cdte.service_type;
		was_tandd = "1"b;
	     end;
	else do;
		cdte.current_service_type = cdte.service_type;
		was_tandd = "0"b;
	     end;

	cdte.dialed_to_procid = "0"b;
	cdte.dial_ev_chn = 0;
	cdte.process = null;
	cdte.user_name = "";

	if cdte.service_type = ANS_SERVICE & ^was_tandd
	then do;					/* if this is normally an answering service channel */
		cdte.in_use = NOW_DIALED;		/* treat this situation as if it were a logout -hold */
		cdte.tra_vec = WAIT_GREETING_MSG;	/* tell dialup_ what to do (say hello and wait for login) */
		word = "device";			/*  send simulated device wakeup to dialup_ */
		call hcs_$wakeup (anstbl.as_procid, cdte.event, addr (word) -> bf, code);
	     end;
	else if ^suppress_hangup
	then do;					/* not A.S. channel; hang it up */
hangup_anyway:
		call astty_$tty_order (cdtep, "hangup", null, (0));
		cdte.in_use = NOW_HUNG_UP;		/* remember that we did */
		call astty_$tty_state (cdtep, code);	/* see if it is hung up yet */
		if cdte.state > TTY_HUNG
		then /* not yet */
		     cdte.tra_vec = WAIT_HANGUP;	/* wait for it; dialup_ listens after it happens */
		else do;				/* channel is already hung up */
			call ipc_$drain_chn (cdte.event, code);
						/* so discard the hangup wakeup, which would
						   just confuse dialup_ if it came along later */
			if ^suppress_listen & cdte.state ^= TTY_MASKED
			then call asu_$asu_listen (cdtep, code);
						/* and do the listen immediately */
			else if cdte.tra_vec = WAIT_FIN_TANDD_ATTACH
						/* we don't want to leave it like this */
			then cdte.tra_vec = WAIT_SLAVE_REQUEST;
						/* good enough till the next time someone wants it */
		     end;
	     end;
	else do;
		call astty_$tty_state (cdtep, code);
		if cdte.state = TTY_DIALED
		then cdte.tra_vec = WAIT_SLAVE_REQUEST;
		else go to hangup_anyway;
	     end;

	return;

     end release_channel;
%page;
find_cdte:
     procedure ();

	do cdtx = 1 to scdtp -> cdt.current_size;
	     cdtep = addr (scdtp -> cdt.cdt_entry (cdtx));
	     if cdte.name = dial_server_request.channel_name
	     then return;
	end;

	cdtep = null ();
	reason = dial_server_request.channel_name;
	reason_code = error_table_$resource_unknown;

	return;

     end find_cdte;
%page;
/**** These next two answer the question of whether a channel
      is available for a given purpose. access_check_process_and_channel
      check the accessability. */

check_dial_access:
     proc returns (bit (1) aligned);

	reason_code = 0;
	if (cdte.twx = 0) | (cdte.current_service_type = INACTIVE) | (cdte.state = TTY_MASKED)
	then reason_code = error_table_$resource_unavailable;
	else if cdte.process = utep
	then reason_code = error_table_$resource_attached;
	else if cdte.current_service_type ^= DIAL_OUT_SERVICE
	then reason_code = error_table_$invalid_resource_state;
	else if cdte.in_use ^= NOW_HUNG_UP
	then reason_code = error_table_$resource_not_free;
	else do;
		if cdte.threads.mother > 0
		then /* now see what mommy has been up to */
		     mpxep = addr (scdtp -> cdt.cdt_entry (cdte.mother).initial_command);
						/* find her diary */
		else mpxep = addr (scdtp -> cdt.fnp_entry (-cdte.mother).mpxe);
		if mpxe.state ^= FNP_UP
		then reason_code = error_table_$resource_unavailable;
						/* oh, hi mom! */
	     end;
	return (reason_code = 0);

     end check_dial_access;

check_priv_attach_access:
     proc returns (bit (1) aligned);

	reason_code = 0;
	if cdte.in_use = NOW_FREE
	then reason_code = error_table_$resource_unavailable;
	else if cdte.process = utep
	then reason_code = error_table_$resource_attached;
	else if cdte.process ^= null
	then reason_code = error_table_$resource_not_free;
	else if cdte.current_service_type ^= SLAVE_SERVICE & ^dial_server_request.flags.tandd_attach
	then reason_code = error_table_$invalid_resource_state;
	return (reason_code = 0);

     end check_priv_attach_access;
%page;
access_check_channel_and_process:
     procedure (a_utep, attach_ring, privileged, operation, a_used_privilege) returns (bit (1) aligned);

declare a_utep pointer;
declare a_used_privilege bit (1) aligned;
declare privileged bit (1) unaligned;
declare operation fixed bin;
declare attach_ring fixed bin (3);

	if static_trace_sw
	then call trace (
		"(access_check) Channel: ^a User: ^a.^a Utep: ^p Ring: ^d Operation: ^[PRIV_ATTACH^;DIAL_OUT^;DIAL_IN^;T_AND_D^]",
		cdte.name, a_utep -> ute.person, a_utep -> ute.project, a_utep, attach_ring, operation);

	if ^aim_check_process_and_channel (a_utep, attach_ring, privileged, operation, a_used_privilege)
	then do;
		reason_code = error_table_$ai_restricted;
		return ("0"b);
	     end;

	if (operation = PRIV_ATTACH & cdte.flags.access_control.priv_attach)
	     | (operation = DIAL_IN & cdte.flags.access_control.dial_server)
	     | (operation = DIAL_OUT & cdte.flags.access_control.dial_out)
	     | (operation = T_AND_D & cdte.flags.access_control.priv_attach)
	then return (check_acs ((cdte.name), make_group_id (a_utep), attach_ring));
	else return ("1"b);
     end access_check_channel_and_process;
%page;
aim_check_process_and_channel:
     procedure (a_utep, attach_ring, privileged, operation, a_used_privilege) returns (bit (1) aligned);

declare a_utep pointer;
declare attach_ring fixed bin (3);
declare privileged bit (1) unaligned;
declare a_used_privilege bit (1) aligned;
declare operation fixed bin;
dcl     access_class_ok bit (1) aligned automatic;

	if static_trace_sw
	then call trace (
		"(aim_check) Channel: ^a User: ^a.^a Utep: ^p Ring: ^d^[ Privileged^] Operation: ^[PRIV_ATTACH^;DIAL_OUT^;DIAL_IN^;T_AND_D^]",
		cdte.name, a_utep -> ute.person, a_utep -> ute.project, a_utep, attach_ring, privileged, operation);



	a_used_privilege = "0"b;

/* Make sure the current access class information is valid. */

	if ^cdte.current_access_class_valid
	then do;
		call INITIALIZE_CURRENT_ACCESS_CLASS (code);
		if code ^= 0
		then return (FALSE);		/* not altogether true, however */
	     end;

	if /* tree */ (operation = DIAL_OUT)
	then if ^cdte.current_access_class_valid	/* range */
	     then access_class_ok = (aim_check_$in_range (requested_access_class, cdte.access_class));
	     else access_class_ok = (aim_check_$equal (requested_access_class, cdte.current_access_class (1)));
						/* We already validated requested_a_c */
	else if ^cdte.current_access_class_valid
	     then if privileged
		then access_class_ok =
			(
			aim_check_$greater_or_equal (a_utep -> ute.process_authorization_range (2),
			cdte.access_class (2)));
		else access_class_ok = (aim_check_$in_range (a_utep -> ute.process_authorization, cdte.access_class));
	     else if privileged
		then access_class_ok =
			(
			aim_check_$greater_or_equal (a_utep -> ute.process_authorization_range (2),
			cdte.current_access_class (1)));
		else access_class_ok =
			(aim_check_$equal (a_utep -> ute.process_authorization, cdte.current_access_class (1)));

	if access_class_ok
	then /* ok to use this channel */
	     return (TRUE);
	else do;					/* not ok, reset access class information */
		call asu_$reset_access_class (cdtep);
		return (FALSE);
	     end;

     end aim_check_process_and_channel;
%page;
aim_check_registered_server_namedup:
     procedure (code) returns (bit (1) aligned);

/**** This procedure is used to enforce the AIM rules for servers.
      There can only be one server per dial_id per access class.
      This is because we have no way to register a dial_id as having
      AIM characteristics. A privileged server serves from system_low
      up to their authorization. A privileged server is defined as one
      established with the comm privilege enabled. If a server is privileged
      the fact is recorded in ute.privileged_dial_server.

      Since processes can (foolishly) turn off their comm privilege
      after becoming privileged registered servers, we can have cases
      where no server can serve a dial request, even though some server
      claims to be serving the territory. This is because both
      ute.privileged_dial_server & the comm privilege must be on
      for the dialing in channel to find the process. */

declare code fixed bin (35);
declare i fixed bin;
declare P ptr;


	do i = 1 to anstbl.current_size;		/* check for user */
	     P = addr (anstbl.entry (i));

	     if consider_ute ()
	     then return ("0"b);			/* found a conflict */
	end;

/* Now check the daemon user table */

	do i = 1 to dutbl.current_size;		/* check for user */
	     P = addr (dutbl.entry (i));
	     if consider_ute ()
	     then return ("0"b);
	end;

/* Now check the absentee user table */

	do i = 1 to autbl.current_size;		/* check for user */
	     P = addr (autbl.entry (i));
	     if consider_ute ()
	     then return ("0"b);

	end;
	return ("1"b);

consider_ute:
     procedure returns (bit (1) aligned);

declare existing_priv_range (2) bit (72) aligned;
declare proposed_priv_range (2) bit (72) aligned;

	existing_priv_range (1) = ""b;		/* system_low */
	existing_priv_range (2) = P -> ute.process_authorization;
	proposed_priv_range (1) = ""b;		/* system_low */
	proposed_priv_range (2) = unspec (sender_authorization);

	if P -> ute.dial_ev_chn = 0
	then return ("0"b);				/* no conflict */
	if ^P -> ute.registered_dial_server
	then return ("0"b);
	if P -> ute.dial_qualifier ^= dial_server_request.dial_qualifier
	then return ("0"b);				/* no conflict */

	if P -> ute.privileged_dial_server		/* system_low --> ute.p_a */
	then do;
		if dial_server_request.privileged_server/* request for priv server */
		then
REJECT_AIM:
		     do;
			code = error_table_$dial_id_busy;
			return ("1"b);
		     end;
		else if aim_check_$in_range (unspec (sender_authorization), existing_priv_range)
		then go to REJECT_AIM;
		else return ("0"b);			/* outside claimed range */
	     end;
	else do;					/* existing server is single level */
		if (dial_server_request.privileged_server
		     & aim_check_$in_range (P -> ute.process_authorization, proposed_priv_range))
		     | (^dial_server_request.privileged_server
		     & aim_check_$equal (P -> ute.process_authorization, unspec (sender_authorization)))
		then go to REJECT_AIM;
	     end;
	return ("0"b);
     end consider_ute;
     end aim_check_registered_server_namedup;
%page;
check_acs:
     procedure (check_name, user_name, user_ring) returns (bit (1) aligned);

/* general procedure to check access on an ACS */

dcl     check_name char (*);
dcl     user_name char (*);
dcl     user_ring fixed bin (3);

	acs_name = check_name;
	reason_code = 0;
	acs_name = rtrim (acs_name, " ") || ".acs";

	call hcs_$get_user_access_modes (as_data_$rcpdir, acs_name, user_name, (user_ring), mode, ""b, code);

	if code ^= 0
	then do;
		if code = error_table_$noentry
		then reason_code = error_table_$insufficient_access;
		else reason_code = error_table_$unable_to_check_access;
		reason = acs_name;
	     end;
	else if (mode & RW_ACCESS) ^= RW_ACCESS
	then reason_code = error_table_$insufficient_access;
	if static_trace_sw
	then call trace_error (reason_code, "(check_acs) ACS: ^a USER: ^a, RING: ^d", acs_name, user_name, user_ring);
	return (reason_code = 0);

     end check_acs;
%page;
/* internal procedures and functions for channel starname handling */

set_desired_channel:
     proc;					/* expand dsr.channel_name */

	if dial_server_request.channel_name = ""
	then do;					/* default null string */
		desired_channel = "**";
		code = 2;
	     end;
	else do;					/* make sure it's a valid name */
		desired_channel = dial_server_request.channel_name;
		call check_star_name_$entry (desired_channel, code);
		if code = error_table_$badstar
		then do;
			reason_code = error_table_$bad_name;
						/* badstar message doesn't scan */
			reason = desired_channel;
		     end;
	     end;
	CAI.channel_name = desired_channel;		/* for auditing */
	star_channel_name = code ^= 0;		/* any star-convention stuff? */
     end set_desired_channel;
%page;
set_requested_channel_access_class:
     procedure ();

	used_privilege = "0"b;
	requested_access_class = aim_util_$get_access_class (unspec (sender_authorization));
						/* until set otherwise */
	if dial_server_request.flags.access_class_specified
	     & ^aim_check_$equal (unspec (sender_authorization), dial_server_request.access_class)
	then do;					/* User requested dial-out at privileged auth */
		if ^sender_authorization.privileges.comm
		then do;
			reason_code = error_table_$insufficient_access;
			reason = "process lacks comm privilege for privileged dial-out";
			return;
		     end;


		if ^aim_check_$greater_or_equal (ute.process_authorization_range (2),
		     dial_server_request.access_class)
		then do;
			reason_code = error_table_$ai_out_range;
			reason = "requested authorization is greater than maximum authorizaton";
			return;
		     end;
		requested_access_class = dial_server_request.access_class;
		used_privilege = "1"b;
	     end;
	else reason_code = 0;			/* no auth requested or same as process auth */

     end set_requested_channel_access_class;
%page;
cdte_matches_desired:
     proc () returns (bit (1) aligned);			/* check cdte channel with desired_channel */

	if ^star_channel_name
	then /* must match exactly, then */
	     if cdte.name = desired_channel
	     then return ("1"b);
	     else if cdte.generic_destination_present
	     then if addr (cdte.initial_command) -> generic_destination = desired_channel
		then return ("1"b);
	call match_star_name_ ((cdte.name), desired_channel, code);
						/* does it fit the pattern? */
	if code ^= 0
	then if cdte.generic_destination_present
	     then call match_star_name_ (addr (cdte.initial_command) -> generic_destination, desired_channel, code);
						/* does channel_desired match a channel alias? */
	return (code = 0);				/* code 0 indicates match */
     end cdte_matches_desired;
%page;
set_dial_out_channel_access_class:
     procedure (code);

declare code fixed bin (35);

	code = 0;

	call asu_$reset_access_class (cdtep);		/* since we own it, we are responsable for setting it into a reasonable state. */
	if cdte.current_access_class_valid
	then return;

	call astty_$tty_order (cdtep, "set_required_access_class", addr (requested_access_class), code);
	if code = -1				/* Channel hung up */
	then code = error_table_$io_no_permission;

	if code = error_table_$io_no_permission
	then return;				/* Let caller decide what to do */
	else if code ^= 0
	then do;
		if code = error_table_$undefined_order_request
		then do;
			code = error_table_$resource_unavailable;
						/* mis-configured */
			call sys_log_ (SL_LOG_BEEP,
			     "dial_ctl_: Autocall channel ^a declared multi-class, but does not support set_required_access_class.",
			     cdte.name);
		     end;
	     end;
	else do;
		cdte.current_access_class (*) = requested_access_class;
		cdte.current_access_class_valid = "1"b;
	     end;
	return;
     end set_dial_out_channel_access_class;

decrement_ndialed:
     procedure ();

	if ute.ndialed_consoles <= 0
	then do;
		ute.ndialed_consoles = 0;
		call sys_log_ (SL_LOG_SILENT, "dial_ctl_: ndialed negative ^a", ute.tty_name);
	     end;
	else ute.ndialed_consoles = ute.ndialed_consoles - 1;
     end decrement_ndialed;

make_group_id:
     procedure (a_utep) returns (char (32));

declare a_utep pointer;
declare group_id char (32);

	group_id = "";
	call ioa_$rsnnl ("^[anonymous^s^;^a^].^a.^a", group_id, (0), (a_utep -> ute.anonymous = 1),
	     a_utep -> ute.person, a_utep -> ute.project, a_utep -> ute.tag);
	return (group_id);
     end make_group_id;
%page;
meter_dut:
     procedure ();					/* meter dialed_up_time */

	if cdte.service_type ^= ANS_SERVICE
	then /* not 'dial' or 'slave' */
	     cdte.dialed_up_time =
		cdte.dialed_up_time + float (anstbl.current_time - cdte.dialup_time, 63) / 1e6 + .5e0;

     end meter_dut;
%page;
convert_aliases:
     procedure (rq_person, rq_project) returns (bit (1));

dcl     rq_person char (22);
dcl     rq_project char (9);

dcl     code fixed bin (35);
dcl     satx fixed bin (35);

	call pnt_manager_$admin_get_entry (rq_person, addr (pnte), code);
	if code = error_table_$id_not_found
	then return (FALSE);
	else if code ^= 0
	then do;
		call sys_log_$error_log (SL_LOG_BEEP, code, ME, "Can't find PNT entry: ^a", rq_person);
		return (FALSE);
	     end;
	else rq_person = substr (pnte.user_id, 1, length (rq_person));

	if rq_project = ""
	then rq_project = substr (pnte.default_project, 1, length (rq_project));
	else do;
		call hash_$search (as_data_$sat_htp, rq_project, satx, code);
		if code ^= 0
		then return (FALSE);
		satp = as_data_$satp;
		satep = addr (sat.project (satx));
		if rq_project ^= project.project_id
		then if rq_project ^= project.alias
		     then do;
			     call sys_log_ (SL_LOG_BEEP, "^a: sat.ht has ""^a"", sat has ""^a"" at ^p", rq_project,
				project.project_id, satep);
			     return (FALSE);
			end;
		rq_project = substr (project.project_id, 1, length (rq_project));
	     end;

	return (TRUE);
     end convert_aliases;

%page;
find_dialable_process:
     procedure returns (pointer);

/**** internal procedure to scan table (answer_table, daemon_user_table, or
      absentee_user_table) and set utep to ptr to entry which matches all
      criteria for dialing.

      Implicit parameters are find_person_project, rq_person, rq_project,
      dial_qualifier, cdte, and utep.

      We expect that at any site where system_high > system_low that
      flags.access_control.slave_dial will be on. This will force lg_ctl_
      to force the user typing the dial request to specify an access
      class in case one was not specified be the communications medium.

      If that flag is on, and cdte.current_access_class_valid is off,
      then there is a bug someplace.

      If that flag is off, and cdte.current_access_class_valid is off,
      then the user simple didn't bother to type -user on the dial
      request. We then require the channel range to include the
      process authorization, though we don't recommend this trick. */

dcl     i fixed bin;
dcl     P ptr;


	ansp = as_data_$ansp;
	do i = 1 to anstbl.current_size;		/* check for user */
	     P = addr (anstbl.entry (i));

	     if consider_ute ()
	     then return (P);
	end;

/* Now check the daemon user table */

	dutp = as_data_$dutp;
	do i = 1 to dutbl.current_size;		/* check for user */
	     P = addr (dutbl.entry (i));
	     if consider_ute ()
	     then return (P);
	end;

/* Now check the absentee user table */

	autp = as_data_$autp;
	do i = 1 to autbl.current_size;		/* check for user */
	     P = addr (autbl.entry (i));
	     if consider_ute ()
	     then return (P);

	end;
	return (null);				/* not found */

consider_ute:
     procedure returns (bit (1) aligned);

	if P -> ute.active ^= NOW_HAS_PROCESS
	then return ("0"b);


	if static_trace_sw
	then if P -> ute.dial_ev_chn ^= 0
	     then call trace (
		     "(find_dialable_process) UTE: name ^a.^a qualifier ^a ^[registered_dial_server^] ^[dialok^] dial_server_ring ^d",
		     P -> ute.person, P -> ute.project, P -> ute.dial_qualifier, P -> ute.registered_dial_server,
		     P -> ute.at.dialok, P -> ute.dial_server_ring);

	if find_person_project			/* see if we want to match by person-project */
	then do;
		if P -> ute.person ^= rq_person
		then return ("0"b);

		if P -> ute.project ^= rq_project
		then return ("0"b);
	     end;

	if ^find_person_project & ^(P -> ute.registered_dial_server)
						/* ^ person.project implies registered server */
	then return ("0"b);


	if P -> ute.dial_qualifier ^= dial_qualifier
	then /* wrong one, or none registered */
	     return ("0"b);

	if ^(P -> ute.at.dialok)
	then /* Is master allowed to have dials? */
	     return ("0"b);

	if P -> ute.dial_ev_chn = 0
	then /* Is master accepting dials? */
	     return ("0"b);

	/*** AIM and ACS checks as explained above */
	/*** Note that dialup_ checked -user NAME against acs. */

	if ^access_check_channel_and_process (P, (P -> ute.dial_server_ring), P -> ute.privileged_dial_server, DIAL_IN,
	     ("0"b))				/* code uninteresting, since we just skip */
	then return ("0"b);

	return ("1"b);

     end consider_ute;

     end find_dialable_process;
%page;
SETUP_REQUEST:
     procedure (code);

dcl     code fixed bin (35) parameter;


	if as_data_$ansp = null
	then do;
		code = 1;				/* Not used, except to check against 0. */
		return;
	     end;
	ansp = as_data_$ansp;
	dutp = as_data_$dutp;
	autp = as_data_$autp;

	request_ptr = a_request_ptr;
	as_request_sender_ptr = a_asr_sender_ptr;

	if as_request_sender.version ^= AS_REQUEST_SENDER_VERSION_2
	then do;
		call sys_log_ (SL_LOG,
		     "dial_ctl_: Program error.  as_request_sender.version (^d) not correct in dial request.  Should be ^d.",
		     as_request_sender.version, AS_REQUEST_SENDER_VERSION_2);
		code = 1;
		return;
	     end;

	process_group_id = as_request_sender.group_id;
	process_id = as_request_sender.process_id;
	process_ring = as_request_sender.validation_level;
	unspec (sender_authorization) = as_request_sender.authorization;

	reason_code = 0;
	reason = "";

	chn = dial_server_request.header.reply_channel;	/* use this channel temporarily */

	if dial_server_request.version ^= dial_server_request_version_4
	then call SEND_ERROR_MESSAGE_AND_REJECT (error_table_$unimplemented_version);

	chn = dial_server_request.dial_control_channel;	/* stop using dsr.header.reply_channel */

/**** Note that at this point, chn could be zero if it was not specified
      in the dial_server_request structure.  We interpret this to mean
      that the user is not interested in any responses from us. */

	call asu_$find_process (process_id, i, utep);	/* locate caller's ate */
	if utep = null ()
	then do;
		call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Can't find process ^12.3b", process_id);
		call SEND_CONTROL_MESSAGE (REQUEST_DENIED);
		goto REQUEST_RETURNS;
	     end;

	cdtep = null ();				/* until we find a channel */
	code = 0;
	return;

     end SETUP_REQUEST;
%page;
DIAL_OUT_CHANNEL_ERROR:
     procedure ();

	if cdte.in_use = NOW_DIALED_OUT
	then do;					/* check for error after dial_out */
		call astty_$tty_order (cdtep, "hangup", null (), (0));
						/* make sure line is hungup, ignore code */
	     end;
	if code = -1
	then call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Channel ^a hung up after dial_out for ^a.^a.", cdte.name,
		ute.person, ute.project);
	else if code = error_table_$request_pending | code = error_table_$undefined_order_request
	then call sys_log_$error_log (0, code, ME, "getting dial_out_status or tty info (^a for ^a.^a).", cdte.name,
		ute.person, ute.project);
	else call sys_log_$error_log (0, code, ME, "dial_out (^a for ^a.^a) failed.", cdte.name, ute.person,
		ute.project);

	cdte.process = null ();			/* cleanup the cdte */
	cdte.dialed_to_procid = (36)"0"b;
	cdte.dial_ev_chn = 0;
	call decrement_ndialed;			/* reduce ate.ndialed_consoles */
	cdte.in_use = NOW_HUNG_UP;

/**** We now set the tra_vec so that when the hangup wakeup comes in we
      will go to the dial_ctl_$dial_term entry. */

	cdte.tra_vec = WAIT_DIAL_RELEASE;

	call REJECT_CHANNEL_REQUEST (error_table_$no_connection, "error in dialing out");
     end DIAL_OUT_CHANNEL_ERROR;
%page;
REJECT_CHANNEL_REQUEST:
     procedure (code, why);

dcl     code fixed bin (35);
dcl     why char (*);

	if code = 0
	then /* default error message */
	     code = error_table_$action_not_performed;

	call convert_status_code_ (code, junk, format);
	reason = rtrim (format) || " " || why;

	CAI.valid.service_info = TRUE;
	CAI.service_info = REQUEST_TYPES (request_type);
	if (request_type = PRIV_ATTACH_CHN_RQ | request_type = TANDD_ATTACH_CHN_RQ)
	then call as_access_audit_$channel (cdtep, null, utep, -AS_AUDIT_CHANNEL_ATTACH, addr (CAI), reason);
	else if request_type = DIAL_OUT_RQ
	then do;
		CAI.valid.service_info = FALSE;
		call as_access_audit_$channel (cdtep, null, utep, -AS_AUDIT_CHANNEL_DIALOUT, addr (CAI), reason);
	     end;
	else if (request_type = RELEASE_CHN_RQ | request_type = TERMINATE_DIAL_OUT_RQ)
	then call as_access_audit_$channel (cdtep, null, utep, -AS_AUDIT_CHANNEL_DETACH, addr (CAI), reason);
	else call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Refused unknown request from ^a.^a; ^a ^a", ute.person,
		ute.project, format, why);

	call SEND_ERROR_MESSAGE_AND_REJECT (code);	/* Doesn't return */
     end REJECT_CHANNEL_REQUEST;
%page;
REJECT_DIALID_REQUEST:
     procedure (code, why);

dcl     code fixed bin (35);
dcl     why char (*);

	if code = 0
	then /* default error message */
	     code = error_table_$action_not_performed;

	call convert_status_code_ (code, junk, format);
	reason = rtrim (format) || " " || why;

	if request_type = START_DIAL_ID_RQ
	then call as_access_audit_$dialid (utep, -AS_AUDIT_DIALID_START, addr (DSI), reason);
	else if request_type = STOP_DIAL_ID_RQ | request_type = RELEASE_DIAL_ID_RQ
	then call as_access_audit_$dialid (utep, -AS_AUDIT_DIALID_STOP, addr (DSI), reason);
	else call sys_log_ (SL_LOG_SILENT, "dial_ctl_: Refused unknown request from ^a.^a; ^a ^a", ute.person,
		ute.project, format, why);

	call SEND_ERROR_MESSAGE_AND_REJECT (code);	/* Doesn't return */
     end REJECT_DIALID_REQUEST;
%page;
SEND_ERROR_MESSAGE_AND_REJECT:
     procedure (code);

/**** This internal procedure informs the requesting process of the error
      and then does a non-local return to abort the request. */

dcl     code fixed bin (35);
dcl     1 rv_message_error aligned based (addr (rv.chan)),	/* how we return a full error code */
	2 error_code fixed bin (35);			/* normal error code */

	if chn ^= 0
	then do;
		rvp = addr (retval);
		unspec (rv) = ""b;
		rv.error_msg = "1"b;		/* Indicate return of error code to sender */
		rv_message_error.error_code = code;	/* set error using other overlay */
		call hcs_$wakeup (process_id, chn, retval, (0));
	     end;
	goto REQUEST_RETURNS;

     end SEND_ERROR_MESSAGE_AND_REJECT;
%page;
SEND_CHANNEL_MESSAGE:
     procedure (message);

dcl     message bit (15) aligned parameter;
dcl     1 rv_chan unal based (addr (rv.chan)),		/* overlay 6 character rv.chan field */
	2 devx fixed bin (17) unal,
	2 line_type bin (17) unal,
	2 pad fixed bin (17) unal;

	rvp = addr (retval);
	unspec (rv) = ""b;
	rv_chan.devx = cdte.twx;
	rv_chan.line_type = cdte.line_type;

	rv.devx_msg = "1"b;
	rv.control.code = message;
	call hcs_$wakeup (cdte.dialed_to_procid, cdte.dial_ev_chn, retval, (0));
	return;

     end SEND_CHANNEL_MESSAGE;
%page;
SEND_CONTROL_MESSAGE:
     procedure (message);

dcl     message bit (15) aligned parameter;

	if chn ^= 0
	then do;
		rvp = addr (retval);
		unspec (rv) = ""b;
		rv.chan = "contrl";			/* Tell user this is control message */
		rv.control.code = message;
		call hcs_$wakeup (process_id, chn, retval, (0));
	     end;
	return;

     end SEND_CONTROL_MESSAGE;
%page;
SERVICE_TYPE:
     procedure (type) returns (character (10) varying);

dcl     type fixed bin (17) unaligned;
dcl     type_names (9) character (10) varying
	   initial ("as", "ftp", "mc", "slave", "dial", "dial_out", "inactive", "mpx", "tandd");

	if type < lbound (type_names, 1) | type > hbound (type_names, 1)
	then return ("?");
	else return (type_names (type));
     end SERVICE_TYPE;
%page;
trace_request:
     procedure (caller);

declare caller char (32);
declare auth char (32) aligned;
declare access_class_string char (32) aligned;

	auth = display_access_class_ (as_request_sender.authorization);
	access_class_string = display_access_class_ (dial_server_request.access_class);
	call trace ("(^a) group_id: ^a process_id: ^w ring: ^d auth: ^a ^[comm priv^]", caller,
	     as_request_sender.group_id, as_request_sender.process_id, as_request_sender.validation_level, auth,
	     addr (as_request_sender.authorization) -> aim_template.privileges.comm);
	call trace (
	     "^5xQualifier: ^a Channel: ^a Destination: ^a Baud: ^d line_type: ^d server_type: ^a Access_class: ^a",
	     dial_server_request.dial_qualifier, dial_server_request.channel_name,
	     dial_server_request.dial_out_destination, dial_server_request.baud_rate, dial_server_request.line_type,
	     dial_server_request.server_type, access_class_string);

	call trace (
	     "^5x^[ start^]^[ stop^]^[ privileged_attach^]^[ release_channel^]^[ registered_server^]^[ no_hangup^]^[ release_dial_id^]^[ tandd_attach^]^[ no_listen^]^[ access_class_specified^]",
	     dial_server_request.start, dial_server_request.stop, dial_server_request.privileged_attach,
	     dial_server_request.release_channel, dial_server_request.registered_server, dial_server_request.no_hangup,
	     dial_server_request.release_dial_id, dial_server_request.tandd_attach, dial_server_request.no_listen,
	     dial_server_request.access_class_specified);
	return;
     end trace_request;

trace:
     procedure options (variable);

declare ioa_$general_rs
	   entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned,
	   bit (1) aligned);
declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
declare cu_$arg_list_ptr entry returns (pointer);

declare ioa_buffer char (1000);
declare code_flag bit (1) aligned;
declare code fixed bin (35) based (code_ptr);
declare code_ptr pointer;
declare (first, control) fixed bin;

	code_flag = "0"b;
	go to COMMON;

trace_error:
     entry options (variable);

	code_flag = "1"b;

COMMON:
	if code_flag
	then do;
		call cu_$arg_ptr (1, code_ptr, (0), (0));
		control = 2;
		first = 3;
	     end;
	else do;
		control = 1;
		first = 2;
	     end;

	call ioa_$general_rs (cu_$arg_list_ptr (), control, first, ioa_buffer, (0), "1"b, "0"b);
						/* pad, but don't NL */

	if code_flag
	then call sys_log_$error_log (SL_LOG_SILENT, code, "dial_ctl_", "^a", ioa_buffer);
	else call sys_log_ (SL_LOG_SILENT, "dial_ctl_: ^a", ioa_buffer);
	return;
     end trace;
%page;
ABORT_DIALIN:
     procedure (P_ec, P_reason);

dcl     P_ec fixed bin (35) parameter;
dcl     P_reason char (*) parameter;

dcl     action fixed bin (17);
dcl     code_reason char (150) varying;
dcl     code_reason_al char (100) aligned;

	if P_ec = 0
	then code_reason = P_reason;
	else do;
		call convert_status_code_ (P_ec, (""), code_reason_al);
		code_reason = rtrim(code_reason_al);
		if P_reason ^= "" 
		then do;
		          code_reason = code_reason || ", ";
			code_reason = code_reason || rtrim(P_reason);
		     end;
	     end;

	if utep ^= null ()
	then do;

		CAI.channel_name = cdte.name;
		CAI.valid = FALSE;
		CAI.valid.access_class = cdte.dialup_flags.current_access_class_valid;
		CAI.access_class = cdte.current_access_class (1);
		CAI.valid.access_class_range = TRUE;
		CAI.access_class_range = cdte.access_class;
		CAI.valid.user_validation_level = TRUE;
		CAI.user_validation_level = ute.initial_ring;

		if dial_qualifier = "system"
		then do;
			action = -AS_AUDIT_CHANNEL_DIAL_SYSTEM;
		     end;
		else do;
			action = -AS_AUDIT_CHANNEL_DIALIN;
			CAI.valid.service_info = TRUE;
			CAI.service_info = dial_qualifier;
		     end;

		call as_access_audit_$channel (cdtep, null, utep, action, addr (CAI), (code_reason));
	     end;
	else call sys_log_ (SL_LOG_SILENT,
	         "DIALIN DENIED^20t^[^a.^a^;^s^s^] ^a to ^a ^[(^a)^]",
		cdte.flags.access_control.slave_dial, cdte.user_name.person, cdte.user_name.project, cdte.name,
		dial_qualifier, (code_reason ^= ""), code_reason);

	cdte.process = null ();
	cdte.dialed_to_procid = ""b;
	cdte.dial_ev_chn = 0;

	if P_ec ^= 0
	then P_code = P_ec;				/* export this error code */
	else P_code = as_error_table_$dialnotup;	/* default error message */

	return;

     end ABORT_DIALIN;
%page;
DIALIN_OK:
     procedure ();

dcl     action fixed bin (17);

	CAI.channel_name = cdte.name;
	CAI.valid = FALSE;
	CAI.valid.access_class = TRUE;
	if cdte.dialup_flags.current_access_class_valid
	then CAI.access_class = cdte.current_access_class (1);
	else CAI.access_class = ute.process_authorization;
	CAI.valid.access_class_range = TRUE;
	CAI.access_class_range = cdte.access_class;
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = ute.initial_ring;

	if dial_qualifier = "system"
	then do;
		action = AS_AUDIT_CHANNEL_DIAL_SYSTEM;
	     end;
	else do;
		action = AS_AUDIT_CHANNEL_DIALIN;
		CAI.valid.service_info = TRUE;
		CAI.service_info = dial_qualifier;
	     end;

	call as_access_audit_$channel (cdtep, null, utep, action, addr (CAI), "");
     end DIALIN_OK;
%page;
NULL_PROC:
     procedure ();

/**** This dummy procedure exists for as_any_other_handler_'s sake.
      It is a dummy cleanup handler, required by as_any_other_handler_. */

	return;
     end NULL_PROC;
%page;
INITIALIZE_CURRENT_ACCESS_CLASS:
     procedure (P_code);

/**** This procedure ensures that the cdte.current_access_class_valid
      bit reflects the true state of the channel, and that the current
      access field in the cdte is up-to-date. */

dcl     P_code fixed bin (35) parameter;		/* status code */
dcl     1 auto_tty_access_class structure aligned like tty_access_class automatic;

	P_code = 0;				/* initialize */

	call asu_$reset_access_class (cdtep);		/* reset configured state */

	if cdte.current_service_type = DIAL_OUT_SERVICE
	then return;

	if ^cdte.current_access_class_valid
	then do;					/* see if we can do it */
		unspec (auto_tty_access_class) = ""b;
		call astty_$tty_order (cdtep, "get_required_access_class", addr (auto_tty_access_class), P_code);
		if P_code = 0 & auto_tty_access_class.access_class_set
		then do;
			cdte.current_access_class_valid = TRUE;
			cdte.current_access_class = auto_tty_access_class.access_class;
		     end;
		else if P_code = 0
		then ;				/* no required access class */
		else if P_code = -1			/* stupid value if channel down */
		then P_code = 0;

		else if P_code = error_table_$undefined_order_request
		then P_code = 0;			/* of if this MUX doesn't support it */
		else /* error of some kind */
		     call sys_log_$error_log (SL_LOG_SILENT, P_code, ME,
			"From get_required_access_class control order on channel ^a.", cdte.name);
	     end;
	else P_code = 0;
	return;
     end INITIALIZE_CURRENT_ACCESS_CLASS;
%page;
/* format: off */
%page; %include absentee_user_table;
%page; %include access_mode_values;
%page; %include aim_template;
%page; %include aim_privileges;
%page; %include access_audit_bin_header;
%page; %include answer_table;
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_request_header;
%page; %include as_request_sender_;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dial_server_request;
%page; %include dialup_values;
%page; %include daemon_user_table;
%page; %include line_types;
%page; %include pnt_entry;

dcl  1 pnte		        structure aligned like pnt_entry;
%page; %include sat;

dcl  satep	        ptr;
%page; %include set_term_type_info;
%page; %include sys_log_constants;
%page; %include terminal_info;
%page; %include tty_access_class;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   dial_ctl_: Channel CHANNEL dialed to Initializer {(PERSON.PROJECT)}

   S:	as (severity2)

   T:	$run

   M:	An additional secondary terminal has been attached to the
   Initializer process as a result of a dial system command.  CHANNEL
   specifies which terminal dialed Initializer.

   A:	If this terminal has been connected to the Initializer by
   an authorized operations staff member, proceed to use it by
   issuing an "accept" command and possibly the "substty" command.
   If this is an invalid attempt to connect to the system, type
   "drop CHANNEL" to disconnect the terminal.


   Message:
   dial_ctl_: ERROR_MESSAGE.  Can't find PNT entry: PERSON_ID

   S:	as (severity2)

   T:	$run

   M:	An attempt was made to find the Person Name Table entry
   of the PERSON_ID specified in a dial preaccess command.  However,
   an error occurred which searching in the PNT.

   A:	$notify_sa

   Message:
   dial_ctl_: sat.ht has PROJECT_ID, sat has OTHER_PROJECT_ID at LOC.

   S:	as (severity2)

   T:	$run

   M:	The System Administrator's Table is inconsistent with the
   location information in its hash table.

   A:	$notify_sa

   Message:
   dial_ctl_: Rejected unknown request from PERSON.PROJECT.  No request flags set in dial_server_request.

   S:	as (severity0)

   T:	$run

   M:	The user PERSON.PROJECT attempted to send an dial_server request
   to the Initializer, but failed to specify what type of request he/she
   wanted.

   A:	$ignore


   Message:
   dial_ctl_: Channel CHANNEL (AIM_CLASS, SERV_TYPE) hung up on Initializer

   S:	as (severity1)

   T:	$run

   M:	The channel CHANNEL with access class AIM_CLASS and service type
   SERV_TYPE hung up.  It had previously been dialed to the Initializer.

   A:	$ignore


   Message:
   dial_ctl_: Channel CHANNEL (AIM_CLASS, SERV_TYPE) hung up on missing process WWWWWWWWWWWW

   S:	as (severity1)

   T:	$run

   M:	The channel CHANNEL with access class AIM_CLASS and service type
   SERV_TYPE hung up.  It had been dialed to a process, but the system cannot
   determine what process it had been connected to.  The process may have
   terminated before the hangup was detected.

   A:	If this happens often, inform the programming staff.


   Message:
   dial_ctl_: Can't find process WWWWWWWWWWW

   S:	as (severity0)

   T:	$run

   M:	An invalid signal was received by the secondary terminal
   manager.

   A:	$note


   Message:
   dial_ctl_: Tracing turned on.

   S:	as (severity1)

   T:	$run

   M:	A system administrator had enabled tracing of the dial_ctl_
   program.  Many status messages will be logged and printed on the
   console.

   A:	$ignore


   Message:
   dial_ctl_: Tracing turned off

   S:	as (severity1)

   T:	$run

   M:	A system administrator has disabled dial_ctl_ tracing.

   A:	$ignore


   Message:
   dial_ctl_: ERROR_MESSAGE. Could not check access to >sc1>admin_acs>tandd.acs for PERSON.PROJECT.

   S:	as (severity0)

   T:	$run

   M:	The user PERSON.PROJECT attempted to tandd_attach a communications
   channel.  This operation is controlled by rw access to the ACS segment
   specified.  For the reason ERROR_MESSAGE, the answering service could not
   check access to the segment.  The user tandd_attach request was refused.

   A:  	$contact_sa


   Message:
   dial_ctl_: ERROR_MESSAGE. Issuing tandd_attach control order for channel CHAN

   S:	as (severity0)

   T:	$run

   M:	The user PERSON.PROJECT attempted to tandd_attach a communications
   channel which failed for the reason given by ERROR_MESSAGE.  The user
   tandd_attach request was refused.

   A:  	$contact_sa


   Message:
   dial_ctl_: Dialing channel CHANNEL (ACC_CLASS) to DESTINATION for PERSON.PROJECT {using comm privilege}

   S:	as (severity0)

   T:	$run

   M:	The user PERSON.PROJECT is dialing out on dial channel CHANNEL
   with access class ACC_CLASS to the destination DESTINATION.  If this
   log message ends with "using comm privilege", then the process dialing
   out has used the comm privilege to circumvent AIM restrictions.

   A:	$ignore


   Message:
   dial_ctl_: ERROR_MESSAGE. after dial_out order (CHANNEL for PERSON.PROJECT)

   S:	as (severity0)

   T:	$run

   M:	The user PERSON.PROJECT is attempting a dial_out of channel
   CHANNEL.  The dial_out control order produced the error ERROR_MESSAGE.
   The dial_out attempt is aborted.

   A:	$note


   Message:
   dial_ctl_: ERROR_MESSAGE. call to astty_$tty_new_proc of CHANNEL for PERSON.PROJECT failed

   S:	as (severity0)

   T:	$run

   M:	An attempt to connect the channel CHANNEL to PERSON.PROJECT failed.
   ERROR_MESSAGE indicates why.

   A:	$contact_sa

   Message:
   dial_ctl_: ERROR_MESSAGE. Attempting to detach CHANNEL from PERSON.PROJECT

   S:	as (severity0)

   T:	$run

   M:	An attempt to disconnect channel CHANNEL from PERSON.PROJECT
   failed.  ERROR_MESSAGE explains why.

   A:	$note


   Message:
   dial_ctl_: Autocall channel CHANNEL declared multi-class, but does not support set_required_access_class.

   S:	as (severity2)

   T:	$run_

   M:	The autocall channel CHANNEL has been declared multi-class in
   the CDT, but the underlying multiplexer does not support the
   set_required_access_class control order.  The channel should be
   defined as single class.  The user's dial out request was refused.

   A:	$contact_sa


   Message:
   dial_ctl_: ndialed negative CHANNEL

   S:	as (severity0)

   T:	$run

   M:	The count of secondary consoles for a user is in error.  A
   terminal is hanging up which claims to be attached to a user but his
   count of attached terminals is zero.

   A:	$note


   Message:
   dial_ctl_: Program error.  as_request_sender.version (N) not correct in dial request.  Should be M.

   S:	as (severity1)

   T:	$run

   M:	There is a mismatch in the version number used by the
   the programs as_request_server_ and dial_ctl_ for the as_request_sender_
   structure.

   A:	$contact


   Message:
   dial_ctl_: Channel CHANNEL hung up after dial_out for PERSON.PROJECT

   S:	as (severity0)

   T:	$run

   M:	During a dial_out of channel CHANNEL by PERSON.PROJECT, the
   channel hung up.  The dial_out attempt was aborted.

   A:	$ignore


   Message:
   dial_ctl_: ERROR_MESSAGE. getting dial_out_status or tty info (CHANNEL for PERSON.PROJECT)

   S:	as (severity0)

   T:	$run

   M:	During a dial_out of channel CHANNEL by PERSON.PROJECT, the
   error ERROR_MESSAGE was returned while attempting to determine if
   the dial_out control order succeeded or failed.

   A:	$ignore


   Message:
   dial_ctl_: ERROR_MESSAGE.  dial_out (CHANNEL for PERSON.PROJECT) failed.

   S:	as (severity0)

   T:	$run

   M:	While attempting to dial_out channel CHANNEL for PERSON.PROJECT,
   the error ERROR_MESSAGE occured.  The dial_out attempt was aborted.

   A:	$ignore


   Message:
   dial_ctl_: Refused unknown request from PERSON.PROJECT; ERROR_MESSAGE REASON

   S:	as (severity0)

   T:	$run

   M:	PERSON.PROJECT send a dial_server request to the Initializer
   of unknown format. It was rejected for the reasons specified in
   ERROR_MESSAGE and REASON.


   Message:
   DIALIN DENIED {PERSON1.PROJECT1} CHANNEL to QUALIFIER {PERSON2.PROJECT2} REASON

   S:	as (severity0)

   T:	$run

   M:	A user on channel CHANNEL attempted to use the "dial" preaccess
   command to dial to QUALIFIER, owned by PERSON2.PROJECT2.  The attempt
   was rejected for REASON.  If the channel check_acs "slave_dial" flag
   was on, then PERSON1.PROJECT1 specifies the identified user on this
   channel.

   A:	$note


   Message:
   DIALIN      {PERSON1.PROJECT1} CHANNEL to QUALIFIER {PERSON2.PROJECT2}

   S:	as (severity0)

   T:     $run

   M:	A user on channel CHANNEL has used the "dial" preaccess command
   to dial the dial qualifier QUALIFIER owned by PERSON2.PROJECT2.  If
   the check_acs "slave_dial" flags was on for the channel, then
   PERSON1.PROJECT1 specifies the identified user.

   A:	$ignore

   Message:
   dial_ctl_: ERROR_MESSAGE  From get_required_access_class control order on channel CHANNEL.

   S:	as (severity0)

   T:	$run

   M:	While attempting to determine whether the channel CHANNEL
   had any access class restrictions imposed on it by the hardcore,
   ERROR_MESSAGE was returned.  The request in progress was aborted.

   A:	$note

   END MESSAGE DOCUMENTATION */

     end dial_ctl_;




		    display_connection_list.pl1     08/04/87  1525.3rew 08/04/87  1222.0      231282



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1987 *
        *                                          *
        ******************************************** */

/****^  HISTORY COMMENTS:
  1) change(87-04-07,Brunelle), approve(87-07-08,MCR7681),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
     New program.
  2) change(87-05-28,GDixon), approve(87-07-08,MCR7720),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Revised to add selection control arguments and to simplify output
         format.
  3) change(87-06-10,GDixon), approve(87-07-08,MCR7720),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Correct error in display of aci.network_type.
      B) Correct length computation for aci.offset.
  4) change(87-07-21,GDixon), approve(87-07-21,MCR7720),
     audit(87-07-22,Hartogs), install(87-08-04,MR12.1-1055):
      A) Correct use of magic numbers.
      B) Comment on why capital U is excluded in the vowel routine.
                                                   END HISTORY COMMENTS */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* display_connection_list:  a utility to display contents of the	       */
/* active_connection_list table, maintained by the connection_list_manager_  */
/* subsystem.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

display_connection_list:
     proc;


/* AUTOMATIC */

dcl  brief_sw			bit(1) aligned automatic;
dcl  channel			char(32) automatic;
dcl  code				fixed bin(35) automatic;
dcl  connection			bit(18);
dcl  entry_var			entry variable;
dcl  offset			fixed bin(18) automatic;
dcl  1 owner			aligned automatic,
       2 id			char(32),
       2 person			char(24),
       2 project			char(12),
       2 tag			char(1) unal,
       2 tag_pad			char(3) unal;
dcl  owner_id			fixed bin(36) automatic;
dcl  star_type			fixed bin(2);
dcl  1 user			aligned automatic like owner;
dcl  user_id			fixed bin(36) automatic;
     

/* ENTRIES */

dcl  check_star_name_		entry (char(*), bit(36), fixed bin(2),
				     fixed bin(35));
dcl  hpriv_connection_list_$get_next	entry (bit (18), ptr, fixed bin (35));
dcl  ioa_				entry() options(variable);
dcl  match_star_name_		entry (char(*), char(*),
				     fixed bin(35));


/* BUILTINS AND CONDITIONS */

dcl (addr, after, before, bit, divide, index, length,
     max, null, rtrim, search, substr, verify, unspec)
				builtin;
dcl (cleanup, linkage_error)		condition;


/* INTERNAL STATIC */

dcl  DISPLAY_CONNECTION_LIST_VERSION	init("1.0") char(3) int static
				options(constant);
dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1)
				     int static options(constant);
dcl  ME				char (23) int static options (constant)
				init ("display_connection_list");

/* EXTERNAL STATIC */

dcl (error_table_$bad_arg,
     error_table_$bad_opt,
     error_table_$noentry)		fixed bin(35) ext static;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INVOCATION TYPE AND ARGUMENTS:				       */
/* 1) Initialize variables, and establish cleanup handler.		       */
/* 2) Create standalone ssu_ invocation for argument processing.	       */
/* 3) Initialize argument handling routines.			       */
/* 4) Process input arguments, reporting any errors as they are encountered. */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

     call initialize_args();
     on cleanup call cleanup_invocation();
     call ssu_$standalone_invocation (sci_ptr, ME,
        DISPLAY_CONNECTION_LIST_VERSION, cu_$arg_list_ptr(), exit_proc, code); 
     call check_invocation_type (ALLOW_COMMAND);
     call process_args();
     call scan_connection_list();

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* REVOCATION AND EXIT:					       */
/*   This point is reached when normal processing completes successfully,    */
/* or when the error$fatal routine is called to abnormally end processing.   */
/*							       */
/* 1) Cleanup the standalone invocation.			       */
/* 2) Return to command processor.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

EXIT:
     call cleanup_invocation();
     return;

exit_proc:
     proc;
     go to EXIT;
     end exit_proc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT PROCESSING:					       */
/* Declare variables and subroutines needed for argument processing.	       */
/*							       */
/* CHECK INVOCATION TYPE:					       */
/* 1) Initialize error handling subroutines.			       */
/* 2) Determine whether invoked as command or af.			       */
/* 3) Is this type of invocation allowed?			       */
/* 4) Initialize af return argument, and index of current argument.	       */
/*							       */
/* SEE OTHER ARGUMENT PROCESSING PROGRAMS:			       */
/*   get_arg, get_ctl_arg, get_opt, get_num_opt			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  af_sw			bit(1) aligned,	/* on: active fnc*/
     arg				char(argl) based(argp),
     argl				fixed bin(21),	/* current arg   */
     argp				ptr,
     argn				fixed bin,	/* arg count     */
     argx				fixed bin,	/* arg index     */
     num_opt			fixed bin,	/* numeric option*/
     opt				char(optl) based(optp),
     optl				fixed bin(21),	/* current option*/
     optp				ptr,
     ret				char(retl) varying based(retp),
     retl				fixed bin(21),	/* af return val */
     retp				ptr,
     sci_ptr			ptr;		/* ssu_ info ptr */

dcl  cu_$arg_list_ptr		entry returns(ptr),
     ssu_$abort_subsystem		entry() options(variable),
     ssu_$arg_ptr			entry (ptr, fixed bin, ptr,
				     fixed bin(21)),
     ssu_$destroy_invocation		entry (ptr),
     ssu_$print_message		entry() options(variable),
     ssu_$return_arg		entry (ptr, fixed bin, bit(1) aligned,
				     ptr, fixed bin(21)),
     ssu_$standalone_invocation	entry (ptr, char(*), char(*), ptr,
				     entry, fixed bin(35));

dcl (ALLOW_COMMAND			init(1),
     ALLOW_AF			init(2),
     ALLOW_COMMAND_AF		init(3)) fixed bin int static options(constant);

check_invocation_type:
     proc (allowed);

dcl  allowed			fixed bin;
dcl (error_table_$active_function,
     error_table_$not_act_fnc)	fixed bin(35) ext static;

     call error$init();
     call ssu_$return_arg (sci_ptr, argn, af_sw, retp, retl);
     if allowed = ALLOW_COMMAND & af_sw then
        call error$fatal (sci_ptr, error_table_$active_function);
     else if allowed = ALLOW_AF & ^af_sw then
        call error$fatal (sci_ptr, error_table_$not_act_fnc);
     else if allowed = ALLOW_COMMAND_AF then;
     if af_sw then
        ret = "";
     argx = 0;
     end check_invocation_type;



/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CLEANUP:						       */
/* 1) Destroy the ssu_ invocation (releasing temp segs obtained thru ssu_).  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

cleanup_invocation:
     proc;

     if sci_ptr ^= null then
        call ssu_$destroy_invocation (sci_ptr);
     end cleanup_invocation;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* display_connection:  Display one matching connection.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  1 begin			aligned automatic,
       2 (connection, network, usage, user, process_id) fixed bin;
dcl  matching_entries		fixed bin;
dcl  need_heading			bit(1) aligned automatic;
dcl  1 width			aligned automatic,
       2 (offset, connection, network, usage, user)
				fixed bin;

display_connection:
     procedure;

     matching_entries = matching_entries + 1;

     if brief_sw then do;
        if need_heading then do;
	 call ioa_ (
	    "^/AT^vtCONNECTION^vtNET^vtUSAGE^vtUSER^vtPROCESS ID",
	    begin.connection, begin.network, begin.usage, begin.user,
	    begin.process_id);
	 need_heading = "0"b;
	 end;
        call ioa_ ("^vo^vt^a^vt^a^vt^a^vt^a^vt^12.3b",
	 width.offset, unspec(aci.offset),
	 begin.connection, aci.connection_name,
	 begin.network, aci.network_service_type,
	 begin.usage, LS_USAGE_VALUES (aci.usage_type),
	 begin.user, aci.user_group_id,
	 begin.process_id, aci.user_process_id);
        end;

     else do;
        call ioa_ ("");
        call ioa_ ("Offset:              ^6.3b^25x Usage:  ^d (^a)",
	 aci.offset, aci.usage_type,
	 LS_USAGE_VALUES (aci.usage_type));
        call ioa_ ("Connection name:     ^32a  Net:  ^a", aci.connection_name,
	 aci.network_service_type);
        call ioa_ ("Connection handle:   ^w",
	 aci.connection_handle);
        call ioa_ ("User name:           ^32a  PID:  ^12.3b",
	 aci.user_group_id, aci.user_process_id);
        call ioa_ ("Owner name:          ^32a  PID:  ^12.3b",
	 aci.owner_group_id, aci.owner_process_id);
        call ioa_ ("Initializer handle:  ^24.3b",
	 aci.owner_initializer_handle);
        call ioa_ ("Terminate event chn: ^24.3b",
	 unspec(aci.terminate_event_channel));
        call ioa_ ("Disconnect entry:    ^a",
	 aci.force_disconnect_entry);
        call ioa_ ("Accounting entry:    ^a",
	 aci.force_accounting_flush_entry);
        end;
     return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


display_connection$init:
     entry;

     matching_entries = 0;
     need_heading = TRUE;
     width.offset = length("AT");
     width.connection = length("CONNECTION");
     width.network = length("NET");
     width.usage = length("USAGE");
     width.user = length("USER");
     begin = 0;
     return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


display_connection$matching_entry_count:
     entry returns (fixed bin);

     return (matching_entries);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


display_connection$set_widths:
     entry;

dcl (BITS_PER_OCTAL_DIGIT		init(3),
     GUTTER			init(2),
     STARTING_COLUMN		init(1))
				fixed bin int static
				options(constant);

     width.offset = max (width.offset,
        divide(length(aci.offset)-index(aci.offset,"1"b)+1 +
        BITS_PER_OCTAL_DIGIT-1,			/* round to next */
        BITS_PER_OCTAL_DIGIT, 17, 0));			/*  octal digit  */
     width.connection = max (width.connection,
        length(rtrim(aci.connection_name)));
     width.network = max (width.network,
        length(rtrim(aci.network_service_type)));
     width.usage = max (width.usage, length(LS_USAGE_VALUES(aci.usage_type)));
     width.user = max (width.user, length(rtrim(aci.user_group_id)));
     begin.connection = STARTING_COLUMN + width.offset + GUTTER;
     begin.network = begin.connection + width.connection + GUTTER;
     begin.usage = begin.network + width.network + GUTTER;
     begin.user = begin.usage + width.usage + GUTTER;
     begin.process_id = begin.user + width.user + GUTTER;
     return;

     end display_connection;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ERROR REPORTING ROUTINES:					       */
/* 1) Nonfatal errors set a switch, which can be tested via error_occurred   */
/*    function.						       */
/* 2) Fatal errors abort the subsystem by calling the exit_proc, which       */
/*    branches to the EXIT label to exit the command.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  error_occurred_sw		bit(1);

error:
     proc options (variable);

dcl  code				fixed bin(35) based (codep),
     codep			ptr;

dcl  cu_$arg_list_ptr		entry returns(ptr),
     cu_$arg_ptr			entry (fixed bin, ptr, fixed bin(21),
				     fixed bin(35)),
     cu_$generate_call		entry (entry, ptr);

dcl  CODE_ARG			fixed bin int static options(constant) init(2),
    (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);

     call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
     if code = 0 then return;
     if code = -1 then code = 0;
     error_occurred_sw = TRUE;
     call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr());
     return;

error$init:
     entry;

     error_occurred_sw = FALSE;
     return;
	

error$occurred:
     entry returns (bit(1));

     return (error_occurred_sw);
	

error$fatal:
     entry options(variable);
	
     call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
     if code = 0 then return;
     if code = -1 then code = 0;
     error_occurred_sw = TRUE;
     call ioa_ ("");
     call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr());
     end error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT GETTING FUNCTIONS:				       */
/*  get_arg: 	Get next argument.				       */
/*  get_arg_count:	Get number of arguments.			       */
/*  get_ctl_arg:	Get next argument, which must be a control argument.     */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_arg:
     proc returns (bit(1));

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);

     if argx < argn then do;
        argx = argx + 1;
        call ssu_$arg_ptr (sci_ptr, argx, argp, argl);
        return (TRUE);
        end;
     else
        return (FALSE);
     end get_arg;


get_ctl_arg:
     proc returns (bit(1));

dcl  index			builtin;

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant),
     error_table_$bad_arg		fixed bin(35) ext static;

     if get_arg() then
        if index(arg, "-") = 1 then
        return (TRUE);
     else
        call error$fatal (sci_ptr, error_table_$bad_arg,
        "^a.^/A control argument was expected.", arg);
     return (FALSE);
     end get_ctl_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CONTROL ARG OPERAND GETTING FUNCTIONS:			       */
/*  get_oct_opt:  Gets next arg, treats it as an octal integer operand.      */
/*  get_opt:      Gets next arg.				       */
/*							       */
/* Both allow the caller to specify whether the operand is required (an      */
/* opt_desc is provided) or optional (opt_desc="").		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


get_oct_opt:
     proc (arg_name, opt_desc) returns (bit(1));

dcl  arg_name			char(*),
     opt_desc			char(*);

dcl  code				fixed bin(35);

dcl  cv_oct_check_			entry (char(*), fixed bin(35))
				     returns(fixed bin(35));

dcl  FALSE			init("0"b) bit(1)
				     int static options(constant),
    (error_table_$bad_arg,
     error_table_$noarg)		fixed bin(35) ext static;

     if argx < argn then do;
        argx = argx + 1;
        call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
        if verify (opt, "01234567") > 0 then go to BAD_OPT;
        num_opt = cv_oct_check_ (opt, code);
        if code ^= 0 then do;
BAD_OPT:	 call error (sci_ptr, error_table_$bad_arg,
	    "^a ^a
^a must be followed by a^[n^] ^a.",
	    arg_name, opt, arg_name,
	    vowel(opt_desc), opt_desc);
	 return (FALSE);
	 end;
        else return (TRUE);
        end;
     else if opt_desc ^= "" then do;
        call error (sci_ptr, error_table_$noarg,
	 "^/^a must be followed by a^[n^] ^a.", arg_name,
	 vowel(opt_desc), opt_desc);
        return (FALSE);
        end;
     else return (FALSE);
     end get_oct_opt;

get_opt:
     proc (arg_name, opt_desc) returns (bit(1));

dcl  arg_name			char(*),
     opt_desc			char(*);

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant),
     error_table_$noarg		fixed bin(35) ext static;

     if argx < argn then do;
        argx = argx + 1;
        call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
        if index(opt, "-") = 1 then do;			/* options cannot*/
	 argx = argx - 1;				/*  look like    */
	 go to NO_OPT;				/*  control args */
	 end;
        else
	 return (TRUE);
        end;

     else
NO_OPT:
     if opt_desc ^= "" then do;
        call error (sci_ptr, error_table_$noarg,
	 "^/^a must be followed by a^[n^] ^a.", arg_name,
	 vowel(opt_desc), opt_desc);
        return (FALSE);
        end;
     return (FALSE);
     end get_opt;


vowel:
     proc (str) returns (bit(1));			/* does opt_desc */
						/* begin with a  */
						/* vowel?	       */

dcl  str				char(*),
    (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);

     if search ("aeiouAEIO", substr(str,1,1)) > 0 then	/* Leave out U:  */
        return (TRUE);				/* "an User..."  */
     else						/* is un-American*/
        return (FALSE);				/* This is kludgy*/
     end vowel;					/*  but it works.*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


group_id:
     procedure (arg) returns (1 like owner);

dcl  arg				char(*);
dcl  1 group			aligned automatic like owner;

     group.id = arg;
     group.person = before(arg,".");
     if group.person = "" then group.person = "*";
     group.project = before(after(arg,"."),".");
     if group.project = "" then group.project = "*";
     group.tag = after(after(arg,"."),".");
     if group.tag = "" then group.tag = "*";
     return (group);

     end group_id;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INITIALIZATION.						       */
/* 1) Initialize variables holding argument values.		       */
/* 2) Initialize ssu_ info pointer.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

initialize_args:
     proc;

     brief_sw = TRUE;
     user, owner, channel = "";
     user_id, owner_id, offset = 0;

     call display_connection$init();

     sci_ptr = null;

     end initialize_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* matching_entry: return TRUE if active_connection_list entry match the     */
/* criteria given in input control args.  Otherwise, return FALSE.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

matching_entry:
     procedure returns (bit(1));

dcl  match			bit(1);

     match = TRUE;
     if offset ^= 0 & match then
        match = (aci.offset = bit(offset));

     if user_id ^= 0 & match then
        match = (aci.user_process_id = bit(user_id));

     if owner_id ^= 0 & match then
        match = (aci.owner_process_id = bit(owner_id));

     if owner.id ^= "" & match then do;
        if owner.person ^= "*" then
	 match = (owner.person = before(aci.owner_group_id,"."));
        if owner.project ^= "*" & match then
	 match = 
	 (owner.project = before(after(aci.owner_group_id,"."),"."));
        if owner.tag ^= "*" & match then
	 match =
	 (owner.tag = after(after(aci.owner_group_id,"."),"."));
        end;

     if user.id ^= "" & match then do;
        if user.person ^= "*" then
	 match = (user.person = before(aci.user_group_id,"."));
        if user.project ^= "*" & match then
	 match = 
	 (user.project = before(after(aci.user_group_id,"."),"."));
        if user.tag ^= "*" & match then
	 match =
	 (user.tag = after(after(aci.user_group_id,"."),"."));
        end;
     
     if channel ^= "" & match then do;
        call match_star_name_ ((aci.connection_name), channel, code);
        match = (code = 0);
        end;

     return (match);

     end matching_entry;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* only_one_entry_matches: returns TRUE if -at was given, because then at    */
/* most one connection list entry will match.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

only_one_entry_matches:
     proc returns (bit(1));

     return (offset ^= 0);

     end only_one_entry_matches;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PROCESS ARGUMENTS					       */
/* 1) Match argument to ctl_arg name and operands.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

process_args:
     proc;

CTL_ARG_LOOP:
     do while (get_ctl_arg ());

        if arg = "-brief" | arg = "-bf" then
	 brief_sw = TRUE;
        else if arg = "-long" | arg = "-lg" then
	 brief_sw = FALSE;

        else if arg = "-owner" then do;
	 if get_opt (arg, "Owner's group id") then
	    owner = group_id (opt);
	 end;

        else if arg = "-owner_id" then do;
	 if get_oct_opt (arg, "octal process id") then
	    owner_id = num_opt;
	 end;

        else if arg = "-user" then do;
	 if get_opt (arg, "User's group id") then
	    user = group_id (opt);
	 end;

        else if arg = "-user_id" | arg = "-pid" |
	      arg = "-process_id" | arg = "-processid" then do;
	 if get_oct_opt (arg, "octal process id") then
	    user_id = num_opt;
	 end;

        else if arg = "-at" | arg = "-offset" | arg = "-ofs" then do;
	 if get_oct_opt (arg, "octal offset of connection list entry") then
	    offset = num_opt;
	 end;

        else if arg = "-channel" | arg = "-chn" then do;
	 if get_opt (arg, "channel number") then do;
	    channel = opt;
	    call check_star_name_ (channel, CHECK_STAR_ENTRY_DEFAULT,
	       star_type, code);
	    call error (sci_ptr, code, "^a ^a", arg, opt);
	    if star_type = STAR_TYPE_MATCHES_EVERYTHING then
	       channel = "";
	    end;
	 end;

        else if index (arg, "-") ^= 1 then
	 call error (sci_ptr, error_table_$bad_arg, "^a
Usage: ^a {-control_args}", arg, ME);

        else
	 call error (sci_ptr, error_table_$bad_opt, "^a", arg);
        end CTL_ARG_LOOP;

     if error$occurred() then				/* stop now if   */
        call error$fatal (sci_ptr, -1);			/* ctl arg errs  */

     end process_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* scan_connection_list:  Walk through connection list entries, displaying   */
/* those that match the user's criteria.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

scan_connection_list:
     procedure;

     on linkage_error begin;
        call error$fatal (sci_ptr, -1,
	 "Incorrect access to the hpriv_connection_list_ gate.");
        end;
     entry_var = hpriv_connection_list_$get_next;		/* force linkage */
     revert linkage_error;				/* error now.    */

     unspec (aci) = ""b;				/* start with return structure clean */
     aci.version = ACT_INFO_VERSION_1;
     connection = "0"b;				/* get 1st entry */

     if brief_sw then do;
        call hpriv_connection_list_$get_next (connection, addr (aci),
	 code);
        do while (code = 0);
	 if matching_entry() then do;
	    call display_connection$set_widths();
	    if only_one_entry_matches() then
	       call display_connection();
	    else
	       code = error_table_$noentry;
	    end;
	 connection = aci.offset;			/* get next entry*/
	 call hpriv_connection_list_$get_next (connection, addr (aci),
	    code);
	 end;
        end;
     else code = error_table_$noentry;

     if code ^= error_table_$noentry then;
     else if brief_sw & only_one_entry_matches() then;
     else do;
        connection = "0"b;				/* get 1st entry */
        call hpriv_connection_list_$get_next (connection, addr (aci),
	 code);
        do while (code = 0);
	 if matching_entry() then do;
	    call display_connection();
	    if only_one_entry_matches() then
	       code = error_table_$noentry;
	    end;
	 connection = aci.offset;			/* get next entry*/
	 call hpriv_connection_list_$get_next (connection, addr (aci),
	    code);
	 end;
        end;

     if code ^= error_table_$noentry then
        call error$fatal (sci_ptr, code, "Getting connection list entries.");

     if display_connection$matching_entry_count() = 0 then
        call error$fatal (sci_ptr, -1,
        "No matching connection list entries were found.");

     end scan_connection_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 %include active_connection_info;

dcl  1 aci			aligned like active_connection_info automatic;
 %include check_star_name;
 %include ls_usage_types;

     end display_connection_list;




		    ec_shift_config_change_.pl1     09/21/87  1209.1rew 09/21/87  1109.0       47619



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(87-06-02,Parisek), approve(86-04-17,MCR7715),
     audit(87-08-06,Fawcett), install(87-08-11,MR12.1-1080):
     Establish the system_control ssu_subsystem_info_ptr so this
     procedure will properly work in the system control environment.
  2) change(87-08-18,Parisek), approve(87-08-18,PBF7715),
     audit(87-09-03,Farley), install(87-09-10,MR12.1-1104):
     Remove unnecessary sc_subsystem_info_ references.
  3) change(87-09-17,Parisek), approve(87-09-18,PBF7715),
     audit(87-09-18,Farley), install(87-09-21,MR12.1-1111):
      a. Remove reference to sc_stat_$master_sci_ptr.
      b. Create our own sci ptr and set sc_stat_$admin_sci_ptr equal to our
         sci_ptr.
      c. Get sc_subsystem_info_ptr based on our new sc_stat_$admin_sci_ptr
         value.
      d. Set sc_subsystem_info.real_iocb to sc_stat_$master_iocb for
         signal_io_.
                                                   END HISTORY COMMENTS */


/* format: style4 */
ec_shift_config_change_: proc (sysdir, old, new, auto_maxu, ncpu, nkmem, nbulk);

/* Procedure to execute shift_config_change.ec, passing the old and new shift,
   the auto_maxu switch, and the configuration parameters: cpu, mem, and bulk,
   with an any_other handler set up to catch any errors in the exec_com and not
   let them abort whatever the caller might be doing (e.g., an accounting update).

   Written by T. Casey, May 1978
   Modified by E. N. Kittlitz, November 1982, first shot at as_check_condition_.

*/

dcl  sysdir char (*);				/* dir where shift_config_change.ec should be */
dcl  (old, new, auto_maxu, ncpu, nkmem, nbulk) fixed bin;	/* old and new shift, and load control parameters */

dcl  as_dump_ entry (char (*));
dcl  condition_ entry (char (*), entry);
dcl  cleanup condition;
dcl  call_ec_ entry options (variable);
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  sc_create_sci_ entry (ptr, fixed bin (35));
dcl  sc_create_sci_$destroy entry (ptr);
dcl  ssu_$get_info_ptr entry (ptr) returns (ptr);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);

dcl  code fixed bin (35);
dcl  bc fixed bin (24);
dcl  entry_type fixed bin (2);
dcl  saved_admin_sci_ptr ptr;
dcl  sci_ptr ptr;
		     
dcl  seg_type fixed bin int static options (constant) init (1);

dcl  (char, ltrim, rtrim, null) builtin;


/* See if there is a shift_config_change.ec (there doesn't have to be) */

	call hcs_$status_minf (sysdir, "shift_config_change.ec", (1), entry_type, bc, code);

/* If there is, execute it after setting up an any_other handler */

	sci_ptr = null;
	saved_admin_sci_ptr = sc_stat_$admin_sci_ptr;
	if code = 0 & entry_type = seg_type then do;
	     call sc_create_sci_ (sci_ptr, code);
	     if code ^= 0 then do;
		call sys_log_$error_log (SL_LOG_SILENT, code, "ec_shift_config_change_",

		     "Failed to establish an SCI environment.");
		goto return_to_caller;
	     end;

	     on cleanup begin;
		sc_stat_$admin_sci_ptr = saved_admin_sci_ptr;
		call sc_create_sci_$destroy (sci_ptr);
	     end;

	     sc_stat_$admin_sci_ptr = sci_ptr;		/* sc_command requires sc_stat_$admin_sci_ptr to be valid */

	     sc_subsystem_info_ptr = ssu_$get_info_ptr (sci_ptr);
	     sc_subsystem_info.real_iocb = sc_stat_$master_iocb;

	     call condition_ ("any_other", ucs);
	     call call_ec_ (rtrim (sysdir) || ">shift_config_change",
		ltrim (char (old)), ltrim (char (new)), ltrim (char (auto_maxu)),
		ltrim (char (ncpu)), ltrim (char (nkmem)), ltrim (char (nbulk)));
	end;

return_to_caller:
	if sci_ptr ^= null then do;
	     sc_stat_$admin_sci_ptr = saved_admin_sci_ptr;
	     call sc_create_sci_$destroy (sci_ptr);
	end;
	return;

ucs: proc (mcptr, condname, coptr, infoptr, continue);

dcl  (mcptr, coptr, infoptr) ptr;
dcl  condname char (*);
dcl  continue bit (1);
dcl  msg char (120);
dcl  i fixed bin;
dcl  non_local bit (1) unaligned;
dcl  as_check_condition_ entry (char (*), bit (1), bit (1));

	call as_check_condition_ (condname, continue, non_local);
	if continue |				/* if not for us */
	     non_local then return;			/* cleanup, but nothing to clean up. */
	call ioa_$rsnnl ("ec_shift_config_change_: Error ^a while executing shift_config_change.ec",
	     msg, i, condname);
	call sys_log_ (SL_LOG_BEEP, "^a", msg);
	call as_dump_ (rtrim (msg));
	goto return_to_caller;

     end ucs;

%include sys_log_constants;
%page;
%include sc_subsystem_info_;
%page;
%include sc_stat_;
%page;
     end ec_shift_config_change_;




		    login_server_info_.pl1          08/04/87  1458.7rew 08/04/87  1221.9       29412



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-08-01,Coren), approve(87-07-13,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Initially written.
  2) change(87-04-26,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

login_server_info_:
     procedure ();

/* Parameters */

dcl  P_code	        fixed bin (35) parameter;
dcl  P_request_ms_dirname   char (*) parameter;
dcl  P_request_ms_entryname char (*) parameter;
dcl  P_server_process_id    bit (36) aligned parameter;
dcl  P_server_event_channel fixed bin (71) parameter;
dcl  P_system_control_dirname char (*) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  event_channel	        fixed bin (71) automatic;

/* Entries */

dcl  initiate_file_	        entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));

/* Internal Static */

dcl  static_answer_table_ptr ptr initial (null ()) internal static;
dcl  system_control_dirname char (168) initial (">system_control_1") internal static;

/* External */

dcl  error_table_$process_unknown fixed bin (35) ext static;

/* Conditions */

dcl  seg_fault_error        condition;

/* Builtin */

dcl  null		        builtin;
%page;
/* Program */

request_info:
     entry (P_server_process_id, P_server_event_channel, P_request_ms_dirname,
	P_request_ms_entryname, P_code);

	if static_answer_table_ptr = null () then
RETRY_ANSWER_TABLE_INITIATION:
	     do;
	     call initiate_file_ (system_control_dirname, "answer_table",
		R_ACCESS, ansp, (0), code);
	     if code ^= 0 then
		goto RETURN;
	     static_answer_table_ptr = ansp;
	end;
	else
	     ansp = static_answer_table_ptr;

	on seg_fault_error begin;
	     static_answer_table_ptr = null ();
	     goto RETRY_ANSWER_TABLE_INITIATION;
	end;
	event_channel = anstbl.ls_request_server_event_channel;
	revert seg_fault_error;

	if event_channel = 0 then do;
	     code = error_table_$process_unknown;	/* server not active */
	     goto RETURN;
	end;

	P_server_process_id = anstbl.ls_request_server_process_id;
	P_server_event_channel = event_channel;
	P_request_ms_dirname = system_control_dirname;
	P_request_ms_entryname = "login_server_requests.ms";
	code = 0;
RETURN:
	P_code = code;
	return;
%page;
test:
     entry (P_system_control_dirname);

/**** This entry, used for debugging, sets the pathname of the system
      control directory name. */

	system_control_dirname = P_system_control_dirname;
	return;

/* format: off */
%page; %include access_mode_values;
%page; %include answer_table;
%page; %include user_table_header;

end login_server_info_;




		    ls_request_server.pl1           08/04/87  1521.5rew 08/04/87  1521.6      106821



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(87-03-10,GDixon), approve(87-07-02,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Initially written. (Resolves dsa 186.)
  2) change(87-07-02,GDixon), approve(87-07-02,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Avoid signalling active_function_error condition when invoked as an active
     function and an error occurs.  The charter of this routine is to print the
     error and return false in this situation.  The error should NOT be printed
     via active_fnc_err_.
                                                   END HISTORY COMMENTS */

ls_request_server:
	proc;
	
dcl	code			fixed bin(35),
	operation			char(5);
	
dcl       null			builtin;
	
dcl	cleanup			condition;

dcl	get_process_id_		entry() returns(bit(36)),
	ls_request_server_$init	entry (fixed bin(35)),
	ls_request_server_$shutdown	entry (fixed bin(35)),
	ls_request_server_$start	entry (fixed bin(35));
	
dcl	ME			char(17) int static options(constant) init("ls_request_server"),
         (error_table_$action_not_performed,
	error_table_$bad_arg,
	error_table_$noarg)		fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

	call DATA_init();
	on cleanup call CLEANUP();
	call ARGS_check (ME, "1.0", ALLOW_COMMAND_AF, exit_proc);
	call ARGS_process (operation);
	call USER_check (operation);
	if operation = "start" then do;
	   call ls_request_server_$init (code);
	   call ERR_fatal (sciP, code,
	      "Initializating login server request server.");
	   call ls_request_server_$start (code);
	   call ERR_fatal (sciP, code,
	      "Starting login server request server.");
	   end;
	else if operation = "stop" then do;
	   call ls_request_server_$shutdown (code);
	   call ERR_fatal (sciP, code, 
	      "Stopping login server request server.");
	   end;
	call ARG_set_return_value ("true");
	call CLEANUP();
	return;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* EXIT PROCEDURE:						       */
/* 1) This procedure is called by ssu_$abort_subsystem when ERR_fatal is     */
/*    called to report a fatal error.				       */
/* 2) It does a non-local goto to the EXIT label to stop execution of the    */
/*    command.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

exit_proc:
	proc;
	go to EXIT;
	end exit_proc;

EXIT:	call ARG_set_return_value ("false");
     	call CLEANUP();
	return;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT PROCESSING:					       */
/* Declare variables and subroutines needed for argument processing.	       */
/*							       */
/* SEE ARGUMENT PROCESSING PROGRAMS:				       */
/*   ARGS_check, ARG_get					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl	af_sw			bit(1) aligned,	/* on: active fnc*/
	arg			char(argl) based(argp),
	argl			fixed bin(21),	/* current arg   */
	argp			ptr,
	argn			fixed bin,	/* arg count     */
	argx			fixed bin,	/* arg index     */
	ret			char(retl) varying based(retp),
	retl			fixed bin(21),	/* af return val */
	retp			ptr,
	sciP			ptr;		/* ssu_ info ptr */

    dcl	ssu_$abort_subsystem	entry() options(variable),
	ssu_$arg_ptr		entry (ptr, fixed bin, ptr, fixed bin(21)),
	ssu_$destroy_invocation	entry (ptr),
	ssu_$print_message		entry() options(variable),
	ssu_$return_arg		entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)),
       	ssu_$standalone_invocation	entry (ptr, char(*), char(*), ptr,
				     entry, fixed bin(35));

dcl      (ALLOW_COMMAND		init(1),
          ALLOW_AF			init(2),
	ALLOW_COMMAND_AF		init(3)) fixed bin int static options(constant);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CHECK INVOCATION TYPE:					       */
/* 1) Initialize error handling subroutines.			       */
/* 2) Determine whether invoked as command or af.			       */
/* 3) Is this type of invocation allowed?			       */
/* 4) Initialize af return argument, and index of current argument.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


ARGS_check:
	proc (caller, version, allowed, exit_procedure);

dcl	caller			char(*),
	version			char(*),
	allowed			fixed bin,
	exit_procedure		entry parameter;

dcl	code			fixed bin(35);

dcl	com_err_			entry() options(variable),
	cu_$arg_list_ptr		entry returns(ptr);

dcl      (error_table_$active_function,
	error_table_$not_act_fnc)	fixed bin(35) ext static;

	call ssu_$standalone_invocation (sciP, caller, version,
	   cu_$arg_list_ptr(), exit_procedure, code);
	if code ^= 0 then do;
	   call com_err_ (code, caller,
	      "Error creating standalone ssu_ invocation.");
	   call exit_procedure();
	   end;

	call ERR_init();
	call ssu_$return_arg (sciP, argn, af_sw, retp, retl);
	if allowed = ALLOW_COMMAND & af_sw then
	   call ERR_fatal (sciP, error_table_$active_function);
	else if allowed = ALLOW_AF & ^af_sw then
	   call ERR_fatal (sciP, error_table_$not_act_fnc);
	else if allowed = ALLOW_COMMAND_AF then;
	if af_sw then
	   ret = "false";				/* Assume failure*/
	argx = 0;
	end ARGS_check;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PROCESS INCOMING ARGUMENTS:				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


ARGS_process:
       	proc (operation);

dcl	operation			char(5);

	operation = "";
	do while (ARG_get());
	   if arg = "start" then
	      operation = arg;
	   else if arg = "stop" then
	      operation = arg;
	   else call ERR (sciP, error_table_$bad_arg, arg);
	   end;
	if ERR_occurred() then go to EXIT;
	if operation = "" then
	   call ERR_fatal (sciP, error_table_$noarg,
	      "^/An operation must be given.  It can be start or stop.");
	end ARGS_process;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT GETTING FUNCTIONS:				       */
/*  ARG_get: 	Get next argument.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

ARG_get:	proc returns (bit(1));

dcl      (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant);

	if argx < argn then do;
	   argx = argx + 1;
	   call ssu_$arg_ptr (sciP, argx, argp, argl);
	   return (TRUE);
	   end;
	else
	   return (FALSE);
	end ARG_get;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARG_set_return_value:					       */
/* 1) Set value of AF return string.  Do nothing if invoked as a command.    */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

ARG_set_return_value:
       	proc (value);

dcl	value			char(*);

	if af_sw then
	   ret = value;

	end ARG_set_return_value;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CLEANUP:						       */
/* 1) Destroy the ssu_ invocation (releasing temp segs obtained thru ssu_).  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

CLEANUP:	proc ();

	if sciP ^= null then
	   call ssu_$destroy_invocation (sciP);

	end CLEANUP;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* DATA INITIALIZATION:					       */
/* 1) Init vars needed by cleanup handler.			       */
/* 2) Init vars used by argument processor.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

DATA_init:
	proc;

	sciP = null;
	operation = "";

	end DATA_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ERROR REPORTING ROUTINES:					       */
/* 1) Nonfatal errors set a switch, which can be tested via error_occurred   */
/*    function.						       */
/* 2) Fatal errors abort the subsystem by calling ssu_$abort_subsystem,      */
/*    which calls the main procedure's exit procedure, which branches to the */
/*    EXIT label to exit the command.				       */
/*							       */
/* Both types of errors suppress (catch and do nothing with) the	       */
/* active_function_error condition signalled by ssu_$print_message and       */
/* ssu_$abort_subsystem when invoked as an active function.  Our program     */
/* only prints error messages and returns false value; it should never allow */
/* active_function_error condition to reach the outside environment.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl	error_occurred_sw		bit(1);

ERR: 	proc options (variable);

    dcl	code			fixed bin(35) based (codep),
	codep			ptr;

    dcl	cu_$arg_list_ptr		entry returns(ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21),
				     fixed bin(35)),
	cu_$generate_call		entry (entry, ptr),
	ioa_			entry() options(variable);

    dcl	CODE_ARG			fixed bin int static options(constant) init(2),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant);

    dcl	active_function_error	condition;

	call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
	if code = 0 then return;
	if code = -1 then code = 0;
	error_occurred_sw = TRUE;
	on active_function_error;			/* do nothing    */
	call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr());
	return;

ERR_init:
	entry;

	error_occurred_sw = FALSE;
	return;

ERR_occurred:
	entry returns (bit(1));

	return (error_occurred_sw);

ERR_fatal:
	entry options(variable);
	
	call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
	if code = 0 then return;
	if code = -1 then code = 0;
	error_occurred_sw = TRUE;
	call ioa_ ("");
	on active_function_error;			/* do nothing    */
	call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr());
	end ERR;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* USER_check:						       */
/* 1) Make sure user of this program is running in Initializer process.      */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


USER_check:
       	proc (operation);

dcl	operation			char(5);

	ansp = as_data_$ansp;
	if ansp = null then
BAD_USER:	   call ERR_fatal (sciP, error_table_$action_not_performed,
	      "^/^[Starting^;Stopping^] the ls_request_server_.
This command can only be used in the Initializer process.",
	      operation = "start");
	if get_process_id_() ^= anstbl.as_procid then
	   go to BAD_USER;

	end USER_check;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 %include answer_table;
 %include as_data_;
 %include user_table_header;

       end ls_request_server;




		    ls_request_server_.pl1          08/04/87  1521.6rew 08/04/87  1521.6      116649



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-08-01,Coren), approve(87-07-13,MCR7737), audit(87-03-09,GDixon),
     install(87-08-04,MR12.1-1055):
     Initially written.
  2) change(87-03-09,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct coding standard errors.
      B) Zero anstbl.ls_request_server_process_id when shutting down.
      C) Initialize connection list manager.
      D) Move initialization of ls_message_buffer out of ls_request_server_
         and into as_init_.
      E) Changed Set_Mseg_Acls to put a correct ACL on the message segment.
      F) Corrects $shutdown deletion of event channel.
  3) change(87-04-23,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
      A) Don't diagnose error is $shutdown finds server already down.
      B) Upgraded for change to answer_table.incl.pl1.
  4) change(87-07-14,GDixon), approve(87-07-14,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
      A) Move initialization of network accounting from act_ctl_$init into
         ls_request_server_$init.  We need network accounting ONLY when
         running the login server.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

ls_request_server_:
     procedure ();

/* Parameters */

dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  abort_label	        label automatic;
dcl  code		        fixed bin (35) automatic;
dcl  error_message	        char (500) automatic;
dcl  request_ms_dirname     char (168) automatic;
dcl  request_ms_entryname   char (32) automatic;
dcl  request_ms_pathname    char (168) automatic;
dcl  system_area_ptr        ptr automatic;

/* Based */

dcl  system_area	        area based (system_area_ptr);

/* External */

dcl (error_table_$action_not_performed,
     error_table_$already_initialized,
     error_table_$noentry,
     error_table_$null_info_ptr,
     error_table_$out_of_sequence)
		        fixed bin (35) ext static;

/* Entries */

dcl  fs_util_$replace_acl   entry (char (*), char (*), ptr, bit (1), fixed bin (35));
dcl  get_group_id_	        entry () returns (char (32));
dcl  get_process_id_        entry () returns (bit (36));
dcl  get_temp_segment_      entry (char (*), ptr, fixed bin (35));
dcl  get_system_free_area_  entry () returns (ptr);
dcl  hpriv_connection_list_$init
		        entry (fixed bin (35));
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_$delete_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  message_segment_$close entry (fixed bin, fixed bin (35));
dcl  message_segment_$create entry (char (*), char (*),
		        fixed bin (35));
dcl  message_segment_$delete entry (char (*), char (*),
		        fixed bin (35));
dcl  message_segment_$open  entry (char (*), char (*), fixed bin,
		        fixed bin (35));
dcl  network_accounting_gate_$clear_table
		        entry (char (*), fixed bin (35));
dcl  network_accounting_gate_$test
		        entry (char (*));
dcl  pathname_	        entry (char (*), char (*)) returns (char (168));
dcl  release_temp_segment_  entry (char (*), ptr, fixed bin (35));
dcl  uc_ls_rq_server_wakeup_ entry (ptr);

/* Constant */

dcl  FALSE	        bit (1) aligned initial ("0"b) internal static options (constant);
dcl  ME		        char (18) initial ("ls_request_server_") internal static options (constant);
dcl  NO_SYSDAEMON	        bit (1) initial ("1"b) internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtin */

dcl  (addr, dimension, null, unspec)
		        builtin;

/* Conditions */

dcl  cleanup	        condition;
%page;
/* Program */
init:
     entry (P_code);

	abort_label = INIT_RETURN;
	ls_request_server_info_ptr = null ();
	on cleanup
	     call Clean_Up ();

/**** Test if ls_request_server_ is already running in this process. */

	ansp = as_data_$ansp;
	if anstbl.ls_request_server_process_id = anstbl.as_procid then
	     call Abort (SL_LOG_SILENT, error_table_$out_of_sequence,
	     "^/ls_request_server_ is already running.  To stop, type:
ls_request_server stop");

/**** Clear out garbage from previous bootload */

	anstbl.ls_request_server_process_id = ""b;
	anstbl.ls_request_server_event_channel = 0;

	system_area_ptr = get_system_free_area_ ();
	allocate ls_request_server_info in (system_area)
	     set (ls_request_server_info_ptr);

	as_data_$ls_request_server_info_ptr =
	     ls_request_server_info_ptr;

	unspec (ls_request_server_info) = ""b;
	ls_request_server_info.version = LS_REQUEST_SERVER_INFO_VERSION_1;

	call get_temp_segment_ (ME, ls_request_server_info.reply_ptr,
	     code);
	call Abort (SL_LOG_BEEP, code,
	     "Could not get temporary segment for ls reply messages.");

	ls_request_server_info.request_ms.dirname = as_data_$sysdir;
	ls_request_server_info.request_ms.entryname =
	     "login_server_requests.ms";
	ls_request_server_info.request_ms.index = 0;	/* for now */

	call Setup_Message_Segment ();
	call Set_Mseg_Acls ();

	ls_request_server_info.flags.initialized = TRUE;

/* Initialize connection list manager */

	call hpriv_connection_list_$init (code);
	if code = error_table_$already_initialized then code = 0;
	if code ^= 0
	then call Abort (SL_LOG_BEEP, code,
	     "Could not initialize the connection list manager.");


/* Initialize network accounting. */

	if as_data_$debug_flag then
	     call network_accounting_gate_$test (as_data_$sysdir);

	call network_accounting_gate_$clear_table (error_message, code);
	if code ^= 0 then do;
	     call Abort (SL_LOG_BEEP, code,
		"Error from " || error_message);
	end;

INIT_RETURN:
	if code ^= 0 then
	     call Clean_Up ();

	P_code = code;
	return;
%page;
start:
     entry (P_code);

/**** This entry is called to actually start the login server request
      server.  We do this by publishing the login server request server
      info in the answer table. */

	abort_label = START_RETURN;
	code = 0;

	ansp = as_data_$ansp;
	ls_request_server_info_ptr = as_data_$ls_request_server_info_ptr;

	anstbl.ls_request_server_process_id = get_process_id_ ();
	call ipc_$create_ev_chn (anstbl.ls_request_server_event_channel, code);
	call Abort (SL_LOG_BEEP, code,
	     "Creating login server request server IPC event channel");

	call ipc_$decl_ev_call_chn (anstbl.ls_request_server_event_channel,
	     uc_ls_rq_server_wakeup_, ls_request_server_info_ptr, 1 /* priority */, code);
	call Abort (SL_LOG_BEEP, code,
	     "Declaring login server request server IPC channel.");

START_RETURN:
	P_code = code;
	return;
%page;
shutdown:
     entry (P_code);

	abort_label = SHUTDOWN_RETURN;
	ansp = as_data_$ansp;
	if anstbl.ls_request_server_process_id ^= anstbl.as_procid then do;
	     if anstbl.ls_request_server_process_id = ""b then do;
	          code = 0;				/* already down  */
		go to SHUTDOWN_RETURN;
		end;
	     call Abort (SL_LOG_SILENT, error_table_$action_not_performed,
		"Server not in operation.");
	     end;

	ls_request_server_info_ptr = as_data_$ls_request_server_info_ptr;
	if ls_request_server_info_ptr = null () then
	     call Abort (SL_LOG_SILENT, error_table_$null_info_ptr,
		"Server not in operation.");

	ls_request_server_info.flags.initialized = FALSE;

	call release_temp_segment_ (ME, ls_request_server_info.reply_ptr,
	     code);
	if code ^= 0 then
	     call Log_Error (code, "Cannot release ls reply temp segment.");

	call message_segment_$close (
	     ls_request_server_info.request_ms.index, code);
	if code ^= 0 then
	     call Log_Error (code,
		"Could not close ls request message segment.");

	anstbl.ls_request_server_process_id = ""b;
	call ipc_$delete_ev_chn (anstbl.ls_request_server_event_channel,
	     code);
	if code ^= 0 then
	     call Log_Error (code,
		"Could not delete request event channel.");
	anstbl.ls_request_server_event_channel = 0;

SHUTDOWN_RETURN:
	P_code = code;
	return;
%page;
Setup_Message_Segment:
     procedure ();

	request_ms_dirname = ls_request_server_info.request_ms.dirname;
	request_ms_entryname = ls_request_server_info.request_ms.entryname;
	request_ms_pathname = pathname_ (request_ms_dirname,
	     request_ms_entryname);

	call message_segment_$delete (request_ms_dirname,
	     request_ms_entryname, code);
	if code ^= 0 then
	     if code ^= error_table_$noentry then
		call Abort (SL_LOG_BEEP, code,
		     "Deleting message segment ^a.",
		     request_ms_pathname);

	call message_segment_$create (request_ms_dirname,
	     request_ms_entryname, code);
	call Abort (SL_LOG_BEEP, code, "Creating message segment ^a.",
	     request_ms_pathname);

	call message_segment_$open (request_ms_dirname, request_ms_entryname,
	     ls_request_server_info.request_ms.index, code);
	call Abort (SL_LOG_BEEP, code, "Opening message segment ^a.",
	     request_ms_pathname);

     end Setup_Message_Segment;
%page;
Set_Mseg_Acls:
     procedure ();

dcl  1 ms_acl	        aligned,			/* like general_acl */
       2 version	        char (8) aligned,
       2 count	        fixed bin,
       2 entries	        (6) like general_acl_entry;

	acl_ptr = addr (ms_acl);
	general_acl.version = GENERAL_ACL_VERSION_1;
	general_acl.count = dimension (ms_acl.entries, 1);
	general_acl.entries (1).access_name = get_group_id_ ();
	general_acl.entries (1).mode = MSEG_QUEUE_CREATOR_INITIAL_ACCESS;
	general_acl.entries (1).status_code = 0;
	general_acl.entries (2).access_name = "*.SysDaemon.*";
	general_acl.entries (2).mode = MSEG_QUEUE_SYSDAEMON_INITIAL_ACCESS;
	general_acl.entries (2).status_code = 0;
	general_acl.entries (3).access_name = "Login_Server.Daemon.*";
	general_acl.entries (3).mode = MSEG_QUEUE_USER_ACCESS;
	general_acl.entries (3).status_code = 0;
	general_acl.entries (4).access_name = "*.SysAdmin.*";
	general_acl.entries (4).mode = MSEG_QUEUE_ADMIN_ACCESS;
	general_acl.entries (4).status_code = 0;
	general_acl.entries (5).access_name = "*.SysMaint.*";
	general_acl.entries (5).mode = MSEG_QUEUE_ADMIN_ACCESS;
	general_acl.entries (5).status_code = 0;
	general_acl.entries (6).access_name = "*.*.*";
	general_acl.entries (6).mode = MSEG_QUEUE_OTHERS_INITIAL_ACCESS;
	general_acl.entries (6).status_code = 0;

	call fs_util_$replace_acl (request_ms_dirname, request_ms_entryname,
	     addr (general_acl), NO_SYSDAEMON, code);
	call Abort (SL_LOG_BEEP, code,
	     "Replacing ACL on message segment ^a.", request_ms_pathname);
	return;
     end Set_Mseg_Acls;
%page;
Clean_Up:
     procedure ();

	if ls_request_server_info_ptr ^= null () then do;
	     free ls_request_server_info;
	     as_data_$ls_request_server_info_ptr = null ();
	end;
	return;
     end Clean_Up;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  report errors via sys_log_$general.			       */
/*							       */
/* Syntax:  call Abort (severity, code, ioa_ctl, args);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Abort:
     procedure options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_sev_code_msg;
	sl_info.caller = ME;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0 then go to abort_label;

     end Abort;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error: report error silently via sys_log_$general, but continue       */
/* execution.						       */
/*							       */
/* Syntax:  call Log_Error (code, ioa_ctl, args);			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Log_Error:
     procedure options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_code_msg;
	sl_info.caller = ME;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));

     end Log_Error;

/* format: off */
%page; %include acl_structures;
%page; %include answer_table;
%page; %include as_data_;
%page; %include ls_request_server_info;
%page; %include mseg_access_mode_values;
%page; %include sys_log_constants;
%page; %include user_table_header;

end ls_request_server_;




		    multiplexer_mgr_.pl1            10/25/89  1159.4r w 10/25/89  1005.1      673974



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* MULTIPLEXER_MGR_ - Manages various multiplexers on behalf of the answering service */
/* Written July-August-September 1978 by Larry Johnson */
/* Modified April 1979 by Larry Johnson so that top level multiplexers need not be FNP's running MCS */
/* Modified July 1979 by C. Hornig so that they don't even need to be FNP's. */
/* Modified Dec. 1980 - Jan. 1981 by Robert Coren to separate start_mpx from listen */
/* Modified Jan. 1981 by Robert Coren to make dump_mpx while load is pending work */
/* Modified December 1981 by Benson I. Margulies for CDT tree. */
/* Modified May 1982 by E. N. Kittlitz for New AS initialization. */
/* Modified June 1982 By B. I. Margulies & E. N. Kittlitz. bug fixes. */
/* Modified June 1982 by E. N. Kittlitz. early stop_mpx bugfix. */
/* Modified August 1982 by Robert Coren to make it possible to prevent automatic reload when calling mpx_crashed. */
/* Modified November 1982 by E. N. Kittlitz. RADC ftp change. BIM fixes.
   don't report load failure to as_init_ on system_init call */
/* Modified January 1983 by E. N. Kittlitz. plotz load of mux with no daughters */
/* Modified August 1983 by Robert Coren. Retry load of non-hardwired mulitplexer if load fails. */
/* Modified August 1983 by Robert Coren. Keep shutdown entry from terminating amultiplexer that wasn't up to begin with. */
/* Modified 83-12-14 BIM. Add shutdown_command for a command interface.
   add count_mpx_users entry. no dump / reload on deconfigure crash. */
/* Modified 84-04-02 BIM. Removed reference to cdte.dim. */
/* Modified 1984-08-02 BIM for bad ref to mpxe.state in shutdown. */
/* Modified 1985-02-19, BIM: to initialize cdte.user_name to a known state */


/****^  HISTORY COMMENTS:
  1) change(86-03-25,MSharpe), approve(86-07-30,MCR7690),
     audit(87-06-25,Parisek), install(87-08-04,MR12.1-1055):
     install(86-10-09,MR12.0-1181):
  2) change(86-06-19,Kissel), approve(86-07-30,MCR7475), audit(86-08-04,Coren),
     install(86-10-09,MR12.0-1181):
     Changed to support the new tty event message format declared in
     net_event_message.incl.pl1 which replaces tty_event_message.incl.pl1.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo */
multiplexer_mgr_:
     procedure;

/* Arguments */

dcl  arg_mpx_name char (*);				/* Name of a multiplexer to load */
dcl  arg_check_sw bit (1) aligned;			/* Check load */
dcl  arg_count fixed bin;				/* for delete_fnp */
dcl  arg_go_sw bit (1) aligned;			/* Go after load */
dcl  arg_force_sw bit (1) aligned;			/* Force operation in spite of who is logged out */
dcl  arg_dump_sw bit (1) aligned;			/* Says whether or not to take a dump */
dcl  arg_reload_sw bit (1) aligned;			/* Says whether to reload after a crash */
dcl  arg_state fixed bin;				/* State of multiplexer */
dcl  arg_code fixed bin (35);				/* Automatic */
dcl  arg_cdtp ptr;					/* Pointer to base of cdt */

/* Automatic */

dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  mpx_name char (32);
dcl  mpx_cdtep ptr;					/* Ptr to either cdte or fnpe for this mpx */
dcl  mpx_display_name char (64) var;			/* For error messages */
dcl  name char (64);				/* Name of entry called */
dcl  n_users fixed bin;				/* Count of users on multiplexer */
dcl  devx fixed bin;				/* Ring0 device-index of multiplexer */
dcl  new_mpx_type fixed bin;				/* Used if mpx_type is changing */
dcl  entvar entry variable options (variable);
dcl  parent_state fixed bin;				/* State of a multiplexers parent */
dcl  fnp_only bit (1) init ("0"b);			/* Used by stop_fnp in a special case which is limited to fnps */
dcl  p ptr;
dcl  shutdown_dump bit (1) aligned;
dcl  smlep ptr;
dcl  up_time fixed bin;
dcl  mpx_was_up bit (1);
dcl  thread_trouble_count fixed bin;
dcl  muxx fixed bin;
dcl  x fixed bin;
dcl  firstx fixed bin;
dcl  d_limit fixed bin;
dcl  BAD_THREADS_LABEL label variable internal;		/* Debuggers and other buggers can put versions of that in their search rules */

dcl  1 ev_msg aligned like event_call_info;
declare  1 auto_condition_info aligned like condition_info;

/* Based */

dcl  mpx_area area (sys_info$max_seg_size) based (mpx_areap);
dcl  1 stop_mpx_list_entry based (smlep) aligned,
       2 mpx_name char (32) unaligned,
       2 next ptr;

/* Static */

dcl  static_cdtp ptr int static init (null ());		/* CDT pointer saved at initialization */
dcl  mpx_areap ptr int static init (null ());		/* Remember pointer to my work area */
dcl  loud bit (1) int static init ("0"b);		/* If set, enables some extra messages */

dcl  stop_mpx_list_ptr_ ptr ext static init (null);	/* list of muxes stopped by early stop_mpx command */

/* Constants */

dcl  proc_name char (16) int static options (constant) init ("multiplexer_mgr_");

/* External */

dcl  asu_$asu_listen entry (ptr, fixed bin (35));
dcl  asu_$attach_channel entry (ptr, fixed bin (35));
dcl  asu_$channel_in_use entry (ptr) returns (bit (1) aligned);
dcl  cdt_mgr_$find_cdt_channel entry (pointer, character (32), fixed binary, bit (1) aligned, fixed binary (35));
dcl  cdt_mgr_$thread_out_cdt_channel entry (ptr, fixed bin);
dcl  dialup_$simulated_wakeup entry (ptr);
dcl  mc_tty_$simulated_wakeup entry (ptr);
dcl  find_condition_info_ entry (pointer, pointer, fixed binary (35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  get_process_id_ returns (bit (36));
dcl  hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35));
dcl  phcs_$get_devx entry (char (*), fixed bin, fixed bin (35));
dcl  phcs_$tty_control entry (char (*), char (*), pointer, fixed bin (35));
dcl  hphcs_$init_channel entry (fixed bin, ptr, fixed bin (35));
dcl  hphcs_$init_multiplexer entry (fixed bin, fixed bin, ptr, fixed bin (35));
dcl  hphcs_$shutdown_multiplexer entry (fixed bin, fixed bin (35));
dcl  hphcs_$terminate_channel entry (fixed bin, fixed bin (35));
dcl  hphcs_$terminate_multiplexer entry (fixed bin, fixed bin (35));
dcl  hphcs_$start_multiplexer entry (fixed bin, fixed bin (35));
dcl  hphcs_$stop_multiplexer entry (fixed bin, fixed bin (35));
dcl  hphcs_$lct_init entry (fixed bin, fixed bin (35));
dcl  sub_err_ entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  iox_$err_no_operation entry;
dcl  mc_commands_$listen_to_ttys entry (char (*));
dcl  mc_commands_$remove_tty entry (char (*), bit (1) aligned, fixed bin (35));

dcl  error_table_$action_not_performed ext fixed bin (35);
dcl  error_table_$null_info_ptr fixed bin (35) ext static;
dcl  error_table_$out_of_sequence fixed bin (35) ext static;
dcl  sys_info$max_seg_size ext fixed bin (19);

dcl  sub_error_ condition;

dcl  (addr, clock, collate, divide, unspec, hbound, index, null, rank, rtrim, substr) builtin;



test_update_mpx:
     entry (arg_mpx_name, arg_test_cdtp, arg_code);
declare  arg_test_cdtp pointer;

	call set_entry_name ("test_update_mpx");
	mpx_name = arg_mpx_name;
	cdtp = arg_test_cdtp;
	call validate_mpx_name (muxx);		/* grab this mux */
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	call update_cdt (muxx);
	return;

/* Entry to "load" a multiplexer */

load_mpx:
     entry (arg_mpx_name, arg_check_sw, arg_go_sw, arg_force_sw, arg_code);

	call set_entry_name ("load_mpx");
RE_LOAD_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then go to ERROR_EARLY_CALL;
	BAD_THREADS_LABEL = RE_LOAD_MPX;

	call validate_mpx_name (muxx);		/* grab this mux */
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if loud
	then call sys_log_ (1, "^a: Loading ^a.^[ check^]^[ go^]^[ force^]", name, mpx_display_name, arg_check_sw,
		arg_go_sw, arg_force_sw);

	call check_parent_state (muxx);		/* Must check to see if my parent is well first */
	if code ^= 0
	then do;
	     call sys_log_ (1, "^a: ^a not loaded. Unable to determine the state of its parent.", name,
		mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;
	if parent_state ^= MPX_UP
	then do;
	     call sys_log_ (1, "^a: ^a cannot be loaded because its parent multiplexer is not running.", name,
		mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;

	if mpxe.state = MPX_BOOT
	then do;					/* Current bootload must finish first */
	     call sys_log_ (1, "^a: Initialization of ^a already in progress.", name, mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;

	if ^arg_force_sw
	then do;					/* Be sure no one is using any of these channels */
	     call count_mpx_users (muxx, n_users);
	     if n_users > 0
	     then do;
		call sys_log_ (1,
		     "^a: User^[s^] of ^d channel^[s^] would be hung up. ^a not loaded. Use -force if necessary.",
		     name, (n_users ^= 1), n_users, (n_users ^= 1), mpx_display_name);
		code = error_table_$action_not_performed;
		return;
	     end;
	end;

	if mpxe.state = MPX_UP
	then do;
	     call shutdown_mpx (mpx_name, "0"b, code);	/* Do a force shutdown of the multiplexer */
	     if code ^= 0
	     then do;
		arg_code = code;
		return;
	     end;
	end;

	call update_cdt (muxx);			/* Perform any pending channel deletions and additions */

	call find_subchannels (muxx, miip);		/* Locate all subchannels of this multiplexer */
	if miip = null
	then do;					/* this is nature's way of saying FOO! */
	     call sys_log_ (1, "^a: ^a has no subchannels.", name, mpx_display_name);
	     code = error_table_$action_not_performed;
	     go to load_mpx_return;
	end;

	mpxe.current_mpx_type = new_mpx_type;

	mpxe.current_service_type = ACTIVE;
	mpxe.flags.check = arg_check_sw;		/* save this info in case we retry the load */

	call phcs_$get_devx (mpx_name, devx, code);
	if code ^= 0
	then do;
	     call sys_log_$error_log (1, code, name, "Unable to get a devx for ^a", mpx_display_name);
	     go to load_mpx_return;
	end;

	call hphcs_$init_multiplexer (devx, mpxe.current_mpx_type, miip, code);
	if code ^= 0
	then do;
	     call sys_log_$error_log (1, code, name, "Unable to initialize ^a.", mpx_display_name);
	     code = error_table_$action_not_performed;
	     go to load_mpx_return;
	end;


/**** mux_init_info contains exactly those channels in the sister */
/**** chain, in the same order. */

	call thread_start (muxx, firstx, d_limit);

	i = 0;
	begin;
declare  1 cdt_list aligned,
	 2 ct fixed bin init (d_limit),
	 2 cdteps (d_limit) ptr unaligned;

	     do x = firstx repeat (cdt_entry (x).threads.next_sister) while (x ^= 0);
		i = i + 1;

		cdtep = addr (cdt.cdt_entry (x));
		if i > d_limit | i > cdt.n_cdtes | cdte.threads.mother ^= muxx
		then call CDT_THREAD_DAMAGE (i, muxx, x);

		cdt_list.cdteps (i) = cdtep;
		cdte.twx = mux_init_info.devx (i);
		if cdte.twx = 0
		then call sys_log_ (1, "^a: No devx assigned to ^a.", name, cdte.name);
		else if cdte.current_service_type ^= MPX_SERVICE
		then do;				/* Init non-multiplexers */
		     call hphcs_$init_channel (cdte.twx, null (), code);
		     if code ^= 0
		     then call sys_log_ (1, "^a: Unable to init channel ^a on ^a.", name, cdte.name, mpx_display_name)
			     ;
		end;
	     end;

	     if i < d_limit				/* ran out of daughters too soon */
	     then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, muxx);

	     mpxe.flags.go = arg_go_sw;
	     mpxe.n_bootloads = mpxe.n_bootloads + 1;
	     mpxe.state = MPX_BOOT;
	     mpxe.time_load_start = clock ();
	     mpxe.flags.listening = "0"b;

	     call build_entvar ("load");
	     call entvar (mpx_name, cdtp, mpx_cdtep, addr (cdt_list), arg_check_sw, code);
	end;
	if code ^= 0
	then do;
	     mpxe.state = MPX_DOWN;
	     if loud
	     then call sys_log_$error_log (1, code, name, "Unable to load ^a.", mpx_display_name);

	     i = 0;
	     do x = firstx repeat (cdt_entry (x).threads.next_sister) while (x ^= 0);
		i = i + 1;			/* safety count */
		cdtep = addr (cdt.cdt_entry (x));
		if i > d_limit | i > cdt.n_cdtes | cdte.mother ^= muxx
		then call CDT_THREAD_DAMAGE (i, muxx, x);
		if cdte.twx ^= 0 & cdte.current_service_type ^= MPX_SERVICE
		then call hphcs_$terminate_channel (cdte.twx, code);
		cdte.twx = 0;
	     end;
	     if i < d_limit				/* ran out of daughters too soon */
	     then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, muxx);

	     call hphcs_$terminate_multiplexer (devx, code);
	     code = error_table_$action_not_performed;
	     go to load_mpx_return;
	end;


	i = 0;
	do x = firstx repeat (cdt_entry (x).threads.next_sister) while (x ^= 0);
	     cdtep = addr (cdt.cdt_entry (x));
	     i = i + 1;
	     if i > d_limit | i > cdt.n_cdtes | cdte.mother ^= muxx
	     then call CDT_THREAD_DAMAGE (i, muxx, x);
	     if cdte.current_service_type = MPX_SERVICE
	     then cdte.twx = 0;
	end;
	if i < d_limit				/* ran out of daughters too soon */
	then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, muxx);

	if mpxe.current_mpx_type ^= MCS_MPX		/* don't do this for FNPs */
	then mpxe.flags.retry_load = ^mpx_cdtep -> cdte.flags.hardwired;
						/* otherwise plan to reload a dialup multiplexer if load fails */

load_mpx_return:
	if miip ^= null ()
	then free mux_init_info;
	arg_code = code;
	return;

/* Entry to perform an orderly shutdown of a multiplexer */
/* NOT FOR EXTERNAL USE. USE COMMAND ENTRY */

shutdown_mpx:
     entry (arg_mpx_name, arg_dump_sw, arg_code);

	call set_entry_name ("shutdown_mpx");
RE_SHUTDOWN_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then go to ERROR_EARLY_CALL;
	BAD_THREADS_LABEL = RE_SHUTDOWN_MPX;

	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if loud
	then call sys_log_ (1, "^a: Shutting down ^a.^[ dump^]", name, mpx_display_name, arg_dump_sw);

	if (mpxe.state = MPX_UP) | (mpxe.state = MPX_BOOT)
	then do;
	     call phcs_$get_devx (mpx_name, devx, code);
	     if code ^= 0
	     then do;
		arg_code = code;
		return;
	     end;

	     mpxe.state = MPX_DOWN;			/* Tell dialup_ not to try to do anything useful with subchannels. */
	     call hphcs_$shutdown_multiplexer (devx, code);
	     if code ^= 0
	     then call sys_log_$error_log (1, code, name, "Shutting down ^a.", mpx_display_name);
	     mpx_was_up = "1"b;
	end;

	else mpx_was_up = "0"b;

	if arg_dump_sw
	then do;					/* Dump required */
	     call build_entvar ("dump");
	     call entvar (mpx_name, cdtp, mpx_cdtep, code);
	     if code ^= 0
	     then call sys_log_$error_log (1, code, name, "Unable to dump ^a.", mpx_display_name);
	end;

	call thread_start (muxx, firstx, d_limit);

	if mpx_was_up
	then do;
	     i = 0;
SHUTDOWN_MPX_LOOP:
	     do x = firstx repeat (cdt.cdt_entry (x).threads.next_sister) while (x ^= 0);
		cdtep = addr (cdt.cdt_entry (x));
		i = i + 1;
		if i > d_limit | i > cdt.n_cdtes | cdte.mother ^= muxx
		then call CDT_THREAD_DAMAGE (i, muxx, x);
		if cdte.current_service_type = MPX_SERVICE
		then do;
		     p = addr (cdte.initial_command);
		     if p -> mpxe.state = MPX_UP | p -> mpxe.state = MPX_BOOT
		     then call shutdown_mpx ((cdte.name), "0"b, code);
		end;
		else if cdte.twx ^= 0
		then do;
		     call hphcs_$terminate_channel (cdte.twx, code);
		     if code ^= 0
		     then call sys_log_$error_log (1, code, name, "Terminating ^a.", cdte.name);
		     if cdte.in_use > NOW_HUNG_UP
		     then do;
			unspec (net_event_message) = "0"b;
						/* Simulate hangup wakeup */
			net_event_message.version = NET_EVENT_MESSAGE_VERSION_1;
			net_event_message.network_type = MCS_NETWORK_TYPE;
			net_event_message.handle = cdte.twx;
			net_event_message.type = MCS_HANGUP_MSG;
			ev_msg.channel_id = cdte.event;
			unspec (ev_msg.message) = unspec (net_event_message);
			ev_msg.sender = get_process_id_ ();
			ev_msg.origin.dev_signal = "0"b;
			ev_msg.origin.ring = 0;
			ev_msg.data_ptr = cdtep;
			if cdte.wakeup_handler = "0"b
			then call dialup_$simulated_wakeup (addr (ev_msg));
			else call mc_tty_$simulated_wakeup (addr (ev_msg));
		     end;
		     cdte.twx = 0;
		end;

	     end SHUTDOWN_MPX_LOOP;

	     if i < d_limit				/* ran out of daughters too soon */
	     then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, muxx);

	     call hphcs_$terminate_multiplexer (devx, code);
	     if code ^= 0
	     then call sys_log_$error_log (1, code, name, "Terminating ^a.", mpx_display_name);
	end;
	arg_code = code;

	return;

/* Entry to dump and shutdown a multiplexer */

shutdown_mpx_command:
     entry (arg_mpx_name, arg_force_sw, arg_code);

	call set_entry_name ("shutdown_mpx_command");
	shutdown_dump = "0"b;
	go to SHUTDOWN_DUMP_COMMON;

dump_mpx:
     entry (arg_mpx_name, arg_force_sw, arg_code);

	shutdown_dump = "1"b;
	call set_entry_name ("dump_mpx");
SHUTDOWN_DUMP_COMMON:
RE_DUMP_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then go to ERROR_EARLY_CALL;
	BAD_THREADS_LABEL = RE_DUMP_MPX;

	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if loud
	then call sys_log_ (1, "^a: Dumping ^a.^[ force^]", name, mpx_display_name, arg_force_sw);

	if ^arg_force_sw
	then do;					/* Be sure no one is using any of these channels */
	     call count_mpx_users (muxx, n_users);
	     if n_users > 0
	     then do;
		call sys_log_ (1,
		     "^a: User^[s^] of ^d channel^[s^] would be hung up. ^a not dumped. Use -force if necessarry.",
		     name, (n_users ^= 1), n_users, (n_users ^= 1), mpx_display_name);
		arg_code = error_table_$action_not_performed;
		return;
	     end;
	end;

	mpxe.flags.retry_load = "0"b;			/* if this results in "load failed", don't reload */

	call shutdown_mpx (mpx_name, shutdown_dump, code);
	arg_code = code;
	return;

/* Entry to start a multiplexer, once it is loaded */

start_mpx:
     entry (arg_mpx_name, arg_force_sw, arg_code);

	call set_entry_name ("start_mpx");
RE_START_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then go to ERROR_EARLY_CALL;
	BAD_THREADS_LABEL = RE_START_MPX;

	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if loud
	then call sys_log_ (1, "^a: Starting ^a.^[ force^]", name, mpx_display_name, arg_force_sw);

	if (mpxe.state ^= MPX_BOOT) & (mpxe.state ^= MPX_UP)
	then do;
	     call sys_log_ (1, "^a: ^a has not been loaded, so it cant be started.", name, mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;

	if (mpxe.state = MPX_UP) & mpxe.flags.go & (mpxe.current_service_type = ACTIVE) & ^arg_force_sw
	then do;
	     call sys_log_ (1, "^a: ^a is already started.", name, mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;

	mpxe.flags.go = "1"b;			/* In case started with nogo */
	mpxe.current_service_type = ACTIVE;

	if mpxe.state = MPX_BOOT
	then do;					/* Boot in progress, can't start yet */
	     call sys_log_ (1, "^a: ^a is currently loading. It will be started when load completes.", name,
		mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;

	call phcs_$get_devx (mpx_name, devx, code);
	if code ^= 0
	then do;
	     call sys_log_$error_log (1, code, name, "Can't get devx for ^a.", mpx_display_name);
	     arg_code = code;
	     return;
	end;

	call hphcs_$start_multiplexer (devx, code);
	if code ^= 0
	then do;
	     call sys_log_$error_log (1, code, name, "Starting ^a.", mpx_display_name);
	     arg_code = code;
	     return;
	end;

	arg_code = 0;
	return;

/* Entry to stop a multiplexer */

stop_mpx:
     entry (arg_mpx_name, arg_code);

	call set_entry_name ("stop_mpx");
RE_STOP_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	BAD_THREADS_LABEL = RE_STOP_MPX;

	if cdtp = null				/* Early call */
	then do;
	     call get_cdt_ptr (arg_code);
	     if arg_code ^= 0
	     then return;
	end;
	if ^cdt.mux_mgr_system_init
	then fnp_only = "1"b;			/* Allow this only for FNP's */

	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if loud
	then call sys_log_ (1, "^a: Stopping ^a", name, mpx_display_name);

	mpxe.current_service_type = INACTIVE;
	mpxe.flags.go = "0"b;

	if mpxe.state = MPX_UP
	then do;
	     call phcs_$get_devx (mpx_name, devx, code);
	     if code ^= 0
	     then do;
		call sys_log_$error_log (1, code, name, "Can't get devx for ^a.", mpx_display_name);
		arg_code = code;
		return;
	     end;
	     call hphcs_$stop_multiplexer (devx, code);
	     if code ^= 0
	     then do;
		call sys_log_$error_log (1, code, name, "Unable to stop ^a.", mpx_display_name);
		arg_code = code;
		return;
	     end;
	     call sys_log_ (1, "^a: ^a is running but no longer accepting calls.", name, mpx_display_name);
	end;

	else if mpxe.state = MPX_BOOT
	then call sys_log_ (1, "^a: ^a is now loading, but will not be started", name, mpx_display_name);

	else do;					/* early stop_mpx */
	     call sys_log_ (1, "^a: ^a will not be loaded.", name, mpx_display_name);
	     smlep = stop_mpx_list_ptr_;
	     do while (smlep ^= null);
		if stop_mpx_list_entry.mpx_name = mpx_name
		then go to end_early_stop_mpx;
		else smlep = stop_mpx_list_entry.next;
	     end;
	     allocate stop_mpx_list_entry;
	     stop_mpx_list_entry.mpx_name = mpx_name;
	     stop_mpx_list_entry.next = stop_mpx_list_ptr_;
	     stop_mpx_list_ptr_ = smlep;
end_early_stop_mpx:
	end;
	arg_code = 0;
	return;

/* Initialize all sub-channels of a multiplexer */
/* This means list to all regular subchannels and initialize ("load") all sub-multiplexers */

listen_mpx:
     entry (arg_mpx_name, arg_code);

dcl  top_mpxep ptr;

	call set_entry_name ("listen_mpx");
RE_LISTEN_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	BAD_THREADS_LABEL = RE_LISTEN_MPX;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then go to ERROR_EARLY_CALL;

	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if loud
	then call sys_log_ (1, "^a: Listening to ^a.", name, mpx_display_name);

	if mpxe.state ^= MPX_UP
	then do;
	     call sys_log_ (1, "^a: ^a is not running. Unable to listen to channels.", name, mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;

	if mpxe.flags.listening			/* don't have to do this again */
	then do;
	     arg_code = 0;
	     return;
	end;

	top_mpxep = mpxep;				/* save this pointer  for listen switch */

	call thread_start (muxx, firstx, d_limit);
	i = 0;
	do x = firstx repeat (cdt.cdt_entry (x).threads.next_sister) while (x ^= 0);
	     cdtep = addr (cdt.cdt_entry (x));
	     i = i + 1;
	     if i > d_limit | i > cdt.n_cdtes | cdte.mother ^= muxx
	     then call CDT_THREAD_DAMAGE (i, muxx, x);
	     if cdte.in_use > NOW_FREE
	     then do;				/* Channel may have been added/deleted during boot */
		if cdte.current_service_type = ANS_SERVICE | cdte.current_service_type = SLAVE_SERVICE
		     | cdte.current_service_type = DIAL_OUT_SERVICE | cdte.current_service_type = FTP_SERVICE
		then do;
		     call asu_$attach_channel (cdtep, code);
		     if code ^= 0
		     then if loud
			then call sys_log_$error_log (1, code, name, "asu_$attach_channel failed ^a", cdte.name);
			else ;
		     else do;
			call asu_$asu_listen (cdtep, code);
			if code ^= 0
			then if code ^= error_table_$action_not_performed
			     then call sys_log_$error_log (1, code, name, "Channel ^a listen failed.", cdte.name);
			     else if loud
			     then call sys_log_ (1, "^a: asu_$listen_chanel failed for ^a.", cdte.name);
		     end;
		end;
		if cdte.current_service_type = MPX_SERVICE
		then do;
		     mpxep = addr (cdte.initial_command);
		     if mpxe.current_service_type = ACTIVE
		     then call load_mpx ((cdte.name), "0"b, "1"b, "1"b, code);
		end;
	     end;
	end;

	call mc_commands_$listen_to_ttys (mpx_name);
	top_mpxep -> mpxe.flags.listening = "1"b;
	arg_code = 0;
	return;

/* Entry to check the state of a multiplexer */

state_mpx:
     entry (arg_mpx_name, arg_state, arg_code);

	call set_entry_name ("state_mpx");
RE_STATE_MPX:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	BAD_THREADS_LABEL = RE_STATE_MPX;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then go to ERROR_EARLY_CALL;

	call validate_mpx_name (muxx);
	if code ^= 0
	then arg_state = MPX_UNKNOWN;
	else arg_state = mpxe.state;
	arg_code = code;
	return;

/* Procedure called by indivudal multiplexer handler to report that it is loaded */

mpx_loaded:
     entry (arg_mpx_name, arg_code);

	call set_entry_name ("mpx_loaded");
RE_MPX_LOADED:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	BAD_THREADS_LABEL = RE_MPX_LOADED;
	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	mpxe.state = MPX_UP;
	mpxe.time_last_load = clock ();
	if mpxe.time_initial_load = 0
	then mpxe.time_initial_load = mpxe.time_last_load;

	call phcs_$tty_control (mpx_name, "copy_meters", null (), (0));
						/* clear out the meters */

	if loud
	then call sys_log_ (1, "^a: Successful load reported for ^a.", name, mpx_display_name);

	if mpxe.flags.go
	then call start_mpx (mpx_name, "1"b, code);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if cdt.flags.go
	then call listen_mpx (mpx_name, code);
	arg_code = code;
	return;

/* Procedure called by individual multiplexer manager to report a unseccussfull load attempt */

mpx_load_failed:
     entry (arg_mpx_name, arg_code);

	call set_entry_name ("mpx_load_failed");
RE_MPX_LOAD_FAILED:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	BAD_THREADS_LABEL = RE_MPX_LOAD_FAILED;
	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	if mpxe.state ^= MPX_BOOT
	then do;					/* Not loading! */
	     call sys_log_ (1, "^a: Report load failure for ^a while not loading.", name, mpx_display_name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;


	if loud
	then call sys_log_ (1, "^a: Load of ^a failed.", name, mpx_display_name);
	call shutdown_mpx (mpx_name, "1"b, code);
	if code ^= 0
	then call sys_log_$error_log (1, code, name, "Trying to shutdown ^a.", mpx_display_name);

	mpxe.state = MPX_DOWN;

/* Now try the load again (if that's what we're supposed to do) */

	if mpxe.flags.retry_load & code = 0		/* as long as the shutdown was OK */
	then call load_mpx (mpx_name, (mpxe.flags.check), (mpxe.flags.go), "1"b, code);

	arg_code = 0;
	return;

/* Procedure called by individual multiplexer manager to report a crash */

mpx_crashed:
     entry (arg_mpx_name, arg_reload_sw, arg_code);

	call set_entry_name ("mpx_crashed");
RE_MPX_CRASHED:
	mpx_name = arg_mpx_name;
	cdtp = static_cdtp;
	BAD_THREADS_LABEL = RE_MPX_CRASHED;
	call validate_mpx_name (muxx);
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	mpxe.time_last_crash = clock ();
	if loud
	then call sys_log_ (1, "^a: Crash reported for ^a.", name, mpx_display_name);
	call shutdown_mpx (mpx_name, arg_reload_sw, code);/* since only FNP's have dumps, and FNPs set this to zero to mean "don't touch" */
	if code ^= 0
	then call sys_log_$error_log (1, code, name, "Shutting down ^a", mpx_display_name);

/* Here we must decide whether or not to reload the mpx */

	up_time = divide (mpxe.time_last_crash - mpxe.time_last_load, 60000000, 17, 0);
						/* Time it stayed up */
	code = 0;

	if arg_reload_sw
	then do;
	     if mpxe.current_service_type = INACTIVE
	     then					/* Stopped by operator */
		call sys_log_ (1, "^a: ^a is stopped and will not be reloaded.", name, mpx_display_name);

	     else if cdt.acceptable_fnp_tbf = 0
	     then					/* No auto reloading */
		call sys_log_ (1, "^a: Automatic reloading is disabled. ^a will not be reloaded.", name,
		     mpx_display_name);

	     else if (mpxe.n_bootloads >= 2) & (up_time < cdt.acceptable_fnp_tbf)
		& (mpxe.last_tbf < cdt.acceptable_fnp_tbf)
	     then call sys_log_ (1, "^a: ^a is in apparent crash loop and will not be reloaded", name, mpx_display_name)
		     ;

	     else call load_mpx (mpx_name, "0"b, "1"b, "0"b, code);
	end;
	mpxe.last_tbf = up_time;			/* Save for next crash */
	arg_code = code;
	return;

/* System initialization entry. Called once per bootload */
/* Its main function is to start the bootload of all configured level-1 multiplexers */

system_init:
     entry (arg_code);

	call set_entry_name ("system_init");
RE_SYSTEM_INIT:
	cdtp = static_cdtp;
	arg_code = 0;
	BAD_THREADS_LABEL = RE_SYSTEM_INIT;

	cdt.flags.go = "0"b;
	cdt.mux_mgr_system_init = "1"b;		/* we are here, lafayette! */

/* First the FNP's */

	do i = 1 to hbound (cdt.fnp_entry, 1);		/* Start bootload on each fnp */
	     fnpep = addr (cdt.fnp_entry (i));
	     mpxep = addr (fnpe.mpxe);
	     if mpxe.state = MPX_DOWN &		/* If its configured */
		mpxe.current_service_type = ACTIVE
	     then do;				/* And it is nornally booted */
		mpx_name = substr (collate (), rank ("a") + i, 1);
		call load_mpx (mpx_name, "0"b, "1"b, "0"b, code);
						/* don't bother as_init_ with load failure */
	     end;
	end;

	call thread_start (0 /* ROOT */, firstx, d_limit);
	i = 0;
	do x = firstx repeat (cdt.cdt_entry (x).next_sister) while (x ^= 0);
	     cdtep = addr (cdt.cdt_entry (x));
	     i = i + 1;
	     if i > d_limit | i > cdt.n_cdtes | cdte.mother ^= 0
	     then call CDT_THREAD_DAMAGE (i, 0, x);
	     mpxep = addr (cdte.initial_command);
	     if mpxe.current_service_type = ACTIVE & mpxe.state = MPX_DOWN
	     then do;
		call load_mpx ((cdte.name), "0"b, "1"b, "0"b, code);
						/* don't bother as_init_ with load failure */
	     end;
	end;
	if i < d_limit
	then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, 0);
	return;


/* This entry is called by as_init_ once per multics bootload. It signifys that the system is
   now really starting and we can listen to real channels. If any FNP's have already booted,
   we listen to them now, otherwise we set a switch so they will be listened to as they boot */

system_go:
     entry;

	call set_entry_name ("system_go");
	cdtp = static_cdtp;

	cdt.flags.go = "1"b;
	do i = 1 to hbound (cdt.fnp_entry, 1);
	     fnpep = addr (cdt.fnp_entry (i));
	     mpxep = addr (fnpe.mpxe);
	     if mpxe.state = MPX_UP
	     then call listen_mpx (substr (collate (), rank ("a") + i, 1), code);
	     if fnpe.threads.daughter_count ^= 0
	     then call go_on_down (-i);
	end;
	call go_on_down (0);			/* top level nonfnps */
	return;

go_on_down:
     procedure (muxx);

declare  muxx fixed bin;
declare  d_limit fixed bin;
declare  firstx fixed bin;
declare  x fixed bin;
declare  check_count fixed bin;

	call thread_start (muxx, firstx, d_limit);
	if d_limit = 0
	then return;

	check_count = 0;
	do x = firstx repeat (cdt.cdt_entry (x).threads.next_sister) while (x ^= 0);
	     cdtep = addr (cdt.cdt_entry (x));
	     check_count = check_count + 1;
	     if check_count > d_limit | check_count > cdt.n_cdtes | cdte.mother ^= muxx
	     then call CDT_THREAD_DAMAGE (check_count, muxx, x);

	     if cdte.current_service_type = MPX_SERVICE
	     then do;
		mpxep = addr (cdte.initial_command);
		if mpxe.state = MPX_UP
		then call listen_mpx ((cdte.name), code);
	     end;
	     if cdte.daughter ^= 0
	     then call go_on_down ((cdte.daughter));	/* will invalidate cdtep */
	end;
	if check_count < d_limit
	then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, muxx);
     end go_on_down;

/* System initialization of all cdte entries */

init_cdt:
     procedure (a_code);
dcl  a_code fixed bin (35);
dcl  nchan fixed bin;
dcl  i fixed bin;

	a_code = 0;
	cdt.mux_mgr_system_init, cdt.flags.go = "0"b;

	nchan = 0;
	do i = 1 to hbound (cdt.fnp_entry, 1);
	     fnpep = addr (cdt.fnp_entry (i));
	     mpxep = addr (fnpe.mpxe);
	     fnpe.boot_segp = null ();
	     fnpe.boot_ev_chan = 0;
	     if mpxe.state ^= MPX_FREE
	     then do;				/* Is configured */
		call mpxe_init (mpxep);
		if fnpe.mpx_type = 0
		then fnpe.mpx_type = MCS_MPX;
		mpxe.current_mpx_type = fnpe.mpx_type;
		mpxe.current_service_type = fnpe.service_type;
		nchan = nchan + 1;
	     end;
	end;

	on sub_err_ go to SKIP;
	do i = 1 to cdt.current_size;
	     cdtep = addr (cdt.cdt_entry (i));
	     if cdte.in_use = CHANNEL_DELETED
	     then do;
		call cdt_mgr_$thread_out_cdt_channel (cdtp, i);
SKIP:
		cdte.in_use = NOW_FREE;
	     end;
	     if cdte.in_use ^= NOW_FREE
	     then do;
		cdte.current_service_type = cdte.service_type;
		cdte.user_name = "";
		cdte.in_use = NOW_HUNG_UP;
		if cdte.current_service_type = MPX_SERVICE
		then do;
		     mpxep = addr (cdte.initial_command);
		     call mpxe_init (mpxep);
		     mpxe.current_mpx_type = cdte.mpx_type;
		     mpxe.current_service_type = cdte.mpx_service;
		end;
		nchan = nchan + 1;
	     end;
	     cdte.event = 0;
	     cdte.twx = 0;
	     cdte.process = null ();
	     cdte.dialed_to_procid = "0"b;
	     cdte.dial_ev_chn = 0;
	     cdte.recent_wakeup_time = 0;
	     cdte.recent_wakeup_count = 0;
	end;
	as_data_$lct_size = nchan + cdt.spare_channel_count;
	revert sub_err_;
	return;
     end init_cdt;

/* Initialize mpxe portion of cdte or fnpe */

mpxe_init:
     proc (p);

dcl  p ptr;

	p -> mpxe.state = MPX_DOWN;
	p -> mpxe.n_bootloads = 0;
	p -> mpxe.time_initial_load = 0;
	p -> mpxe.time_last_load = 0;
	p -> mpxe.time_last_crash = 0;
	p -> mpxe.time_load_start = 0;
	p -> mpxe.last_tbf = 0;
	p -> mpxe.current_mpx_type = 0;
	p -> mpxe.flags = "0"b;

	return;

     end mpxe_init;

/* Procedure to validate a multiplexer name and setup some variables and pointers describing it */

validate_mpx_name:
     procedure (tablex);

dcl  tablex fixed bin;				/* negative for fnp, as per cdt_mgr_ */
dcl  fnp_sw bit (1) aligned;
dcl  msg char (128) var;

	if cdtp = null ()
	then do;					/* To early in initialization */
	     call sys_log_ (1, "^a: Command used too early in answering service initialization. ^a", name, mpx_name);
	     code = error_table_$action_not_performed;
	     return;
	end;

	if mpx_areap = null ()
	then mpx_areap = get_system_free_area_ ();

	on sub_error_				/* cdt_mgr_ is upset */
	     begin;
	     call find_condition_info_ (null, addr (auto_condition_info), (0));
	     sub_error_info_ptr = auto_condition_info.info_ptr;
	     code = sub_error_info.status_code;
	     call sys_log_ (1, code, name, "cdt_mgr_$find_cdt_channel: ^a", sub_error_info.info_string);
	     call CDT_THREAD_DAMAGE$$BRIEF;
	end;

	call cdt_mgr_$find_cdt_channel (cdtp, mpx_name, tablex, fnp_sw, code);

	if code ^= 0				/* noentry is only defined problem */
	then do;
	     msg = "is not defined in the CDT.";
	     return;
	end;

	if fnp_sw
	then do;
	     fnpep = addr (cdt.fnp_entry (-tablex));
	     mpxep = addr (fnpe.mpxe);
	     msg = "is not a configured FNP";
	     if fnpe.state = MPX_FREE
	     then go to bad_mpx_name;
	     mpx_display_name = "FNP " || rtrim (mpx_name);
						/* For error messages */
	     mpx_cdtep = fnpep;
	     if mpxe.current_mpx_type = 0
	     then mpxe.current_mpx_type = fnpe.mpx_type;
	     new_mpx_type = fnpe.mpx_type;		/* This type never changes */
	end;
	else do;					/* Multiplexed channel */
	     msg = ". Command restricted to top-level multiplexers until AS initialization complete.";
	     if fnp_only & index (mpx_name, ".") > 0
	     then go to bad_mpx_name;

	     cdtep = addr (cdt.cdt_entry (tablex));
	     msg = "is not configured as a multiplexer.";
	     if cdte.current_service_type ^= MPX_SERVICE
	     then go to bad_mpx_name;
	     mpx_display_name = "multiplexer " || rtrim (mpx_name);
	     mpxep = addr (cdte.initial_command);
	     mpx_cdtep = cdtep;
	     if mpxe.current_mpx_type = 0
	     then					/* No current type */
		mpxe.current_mpx_type = cdte.mpx_type;
	     new_mpx_type = cdte.mpx_type;		/* This will be type at next load */
	end;

	fnpep, cdtep = null ();
	code = 0;
	return;
bad_mpx_name:
	call sys_log_ (1, "^a: Invalid multiplexer name: ""^a"" ^a", name, mpx_name, msg);
	code = error_table_$action_not_performed;
     end validate_mpx_name;


/* Procedure to compute one entry variable */

build_entvar:
     proc (action);

dcl  action char (*);

dcl  type_name char (32) var;
dcl  (segname, entname) char (32);

	entvar = iox_$err_no_operation;		/* The error default */
	if mpxe.current_mpx_type < 1 | mpxe.current_mpx_type > hbound (mpx_types, 1)
	then return;
	type_name = rtrim (mpx_types (mpxe.current_mpx_type));
	segname = "as_" || type_name || "_mpx_";	/* As_XXXXX_mpx_ */
	entname = type_name || "_" || action;		/* XXXXX_(load dump) */
	call hcs_$make_entry (null (), segname, entname, entvar, code);
	if code = 0
	then return;

     end build_entvar;

/* Save the name of the entry called */
/* and other misc setup */

set_entry_name:
     proc (e);

dcl  e char (*);

	miip = null;
	thread_trouble_count = 0;
	name = proc_name || "$" || e;
	return;

     end set_entry_name;

/* Get a list of all sub-channels on a multiplexor */
/* This is simply all channels that match the starname mpxname.* */

find_subchannels:
     proc (muxx, p);

dcl  muxx fixed bin;				/* stock cdtx -- fixed bin <0 for fnp, >0 for cdt */
dcl  firstx fixed bin;
dcl  d_limit fixed bin;
dcl  x fixed bin;
dcl  p ptr;
dcl  check_count fixed bin;

	call thread_start (muxx, firstx, d_limit);
	if d_limit = 0
	then return;

	mii_chan_count = d_limit;
	allocate mux_init_info in (mpx_area) set (p);

	check_count = 0;
	do x = firstx repeat (cdt.cdt_entry (x).next_sister) while (x ^= 0);
	     check_count = check_count + 1;
	     if check_count > d_limit | check_count > cdt.n_cdtes
						/** **/
		| cdt.cdt_entry (x).threads.mother ^= muxx
	     then do;
		free mux_init_info;
		call CDT_THREAD_DAMAGE (check_count, muxx, x);
	     end;
	     p -> mux_init_info.name (check_count) = cdt.cdt_entry (x).name;
	     p -> mux_init_info.devx (check_count) = 0;
	end;
	if check_count < d_limit
	then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (check_count, muxx);

     end find_subchannels;

/* Count all the users of a multiplexer */

count_mpx_users:
     proc (muxx, n);

dcl  muxx fixed bin;
dcl  j fixed bin;
dcl  n fixed bin;
dcl  (firstx, d_limit, check_count) fixed bin;
dcl  x fixed bin;


	n = 0;
	call thread_start (muxx, firstx, d_limit);
	if d_limit = 0
	then return;

	check_count = 0;
	do x = firstx repeat (cdt.cdt_entry (x).threads.next_sister) while (x ^= 0);

	     check_count = check_count + 1;
	     if check_count > d_limit | check_count > cdt.n_cdtes | cdt.cdt_entry (x).mother ^= muxx
	     then call CDT_THREAD_DAMAGE (check_count, muxx, x);
	     if cdt.cdt_entry (x).current_service_type = MPX_SERVICE
	     then do;				/* Count users down the tree */
		call count_mpx_users (x, j);
		n = n + j;
	     end;
	     else if asu_$channel_in_use (addr (cdt.cdt_entry (x)))
	     then n = n + 1;
	end;
	if check_count < d_limit
	then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (check_count, muxx);
     end count_mpx_users;

/* Procedure to get the state of a multiplexers parent */

check_parent_state:
     proc (muxx);

dcl  muxx fixed bin;
dcl  tp pointer;

	if muxx < 0
	then tp = addr (cdt.fnp_entry (-muxx).threads);
	else tp = addr (cdt.cdt_entry (muxx).threads);

	if tp -> channel_threads.mother = 0		/* top level mpx */
	then do;
	     parent_state = MPX_UP;
	     code = 0;
	     return;
	end;

	if tp -> channel_threads.mother < 0
	then call state_mpx (substr (collate (), rank ("a") - tp -> channel_threads.mother, 1), parent_state, code);
	else call state_mpx ((cdt.cdt_entry (tp -> channel_threads.mother).name), parent_state, code);

     end check_parent_state;

/* Procedure to perform pending channel additions and deletions before a multiplexer is loaded */

update_cdt:
     procedure (muxx);

declare  dx fixed bin;
declare  x fixed bin;
declare  muxx fixed bin;
declare  (firstx, d_limit, check_count) fixed bin;
declare  local_cdtep pointer;
declare  1 L_CDTE aligned like cdte based (local_cdtep);
declare  p pointer;

	call thread_start (muxx, firstx, d_limit);
	if d_limit = 0
	then return;

	check_count = 0;
	x = firstx;
CONSIDER_EACH:
	do while (x ^= 0);				/* repeat done by hand */
	     local_cdtep = addr (cdt.cdt_entry (x));
	     check_count = check_count + 1;
	     if check_count > d_limit | check_count > cdt.n_cdtes | L_CDTE.mother ^= muxx
	     then call CDT_THREAD_DAMAGE (check_count, muxx, x);


	     if L_CDTE.in_use = CHANNEL_DELETED | L_CDTE.in_use = NOW_FREE
						/* NOW_FREE really shouldn't happen, but ... */
	     then do;

		if L_CDTE.daughter_count > 0
		then call update_cdt (x);		/* get the whole family */
		L_CDTE.in_use = NOW_FREE;
		L_CDTE.twx = 0;
		L_CDTE.event = 0;

		dx = x;				/** protect against deletions */
		x = L_CDTE.threads.next_sister;

		call cdt_mgr_$thread_out_cdt_channel (cdtp, dx);

	     end;					/* deletion case */

	     else
NON_DELETED:
		do;
		if L_CDTE.in_use = NOT_CONFIGURED
		then do;
		     L_CDTE.in_use = NOW_HUNG_UP;
		     L_CDTE.current_service_type = L_CDTE.service_type;
		     L_CDTE.twx = 0;
		     L_CDTE.event = 0;
		     L_CDTE.process = null ();
		     L_CDTE.dialed_to_procid = ""b;
		end;
		else if L_CDTE.current_service_type = MC_SERVICE
		then do;
		     if L_CDTE.service_type ^= MC_SERVICE
		     then				/* And we are about to take it away */
			call mc_commands_$remove_tty ((L_CDTE.name), ""b, code);
						/* Co-operate */
		end;

		else if L_CDTE.current_service_type = MPX_SERVICE
		then do;
		     if L_CDTE.service_type ^= MPX_SERVICE
		     then L_CDTE.initial_command = "";
		end;

		L_CDTE.current_service_type = L_CDTE.service_type;
		if L_CDTE.current_service_type = MPX_SERVICE
		then do;				/* Get multiplexers ready */
		     p = addr (L_CDTE.initial_command);
		     call mpxe_init (p);
		     p -> mpxe.current_mpx_type = L_CDTE.mpx_type;
		end;
		if L_CDTE.daughter_count > 0
		then call update_cdt (x);
		x = L_CDTE.threads.next_sister;
	     end NON_DELETED;
	end CONSIDER_EACH;

     end update_cdt;


thread_start:
     procedure (muxx, firstx, d_limit);

declare  firstx fixed bin;				/* first cdte to examine */
declare  d_limit fixed bin;				/* number of daughters you should find */
declare  muxx fixed bin;

	if muxx < 0
	then do;
	     firstx = cdt.fnp_entry (-muxx).threads.daughter;
	     d_limit = cdt.fnp_entry (-muxx).threads.daughter_count;
	end;
	else if muxx > 0
	then do;
	     firstx = cdt.cdt_entry (muxx).threads.daughter;
	     d_limit = cdt.cdt_entry (muxx).threads.daughter_count;
	end;
	else if muxx = 0				/* not used yet, but not a bad idea */
	then do;
	     firstx = cdt.threads.daughter;
	     d_limit = cdt.threads.daughter_count;
	end;

	if (d_limit = 0) ^= (firstx = 0)
	then call CDT_THREAD_DAMAGE$$DAUGHTERS (muxx);
     end thread_start;

get_cdt_ptr:
     procedure (code);

declare  code fixed bin (35);
declare  cdt_mgr_$init entry (character (*), pointer, fixed binary (35));
declare  cdt_mgr_$thread entry (pointer, fixed binary (35));

	cdtp, static_cdtp = null;
	on sub_error_
	     begin;
	     call find_condition_info_ (null, addr (auto_condition_info), (0));
	     sub_error_info_ptr = auto_condition_info.info_ptr;
	     cdtp = sub_error_info.info_ptr;		/* message in a bottle */
	     call sys_log_$error_log (0, sub_error_info.status_code, name, "cdt_mgr_$init: ^a",
		sub_error_info.info_string);		/* for now we rethread and call it a live baby */

	     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, sub_error_info.status_code, name, "cdt_mgr_$thread: ^a",
		     sub_error_info.info_string);
		if ^sub_error_info.default_restart	/* not warning */
		then do;
		     call sys_log_ (2, "^a: CDT rethreading failed.", name);
		     code = sub_error_info.status_code;
		     go to RETURN;
		end;
	     end;
	     if cdtp = null
	     then go to GIVE_UP;
	     call sys_log_ (0, "^a: Rethreading CDT.", name);
	     call cdt_mgr_$thread (cdtp, (0));		/* code uninteresting with handler */
	     call sys_log_ (0, "^a: Rethreading of CDT complete.", name);
	     static_cdtp = cdtp;
/**** * return to cdt_mgr_$init */
	end;

	call cdt_mgr_$init (sc_stat_$sysdir, cdtp, code);
	if code ^= 0
	then do;
GIVE_UP:
	     call sys_log_$error_log (1, code, name, "cdt_mgr_$init failed.");
	     return;
	end;

	call init_cdt (code);
	if code ^= 0
	then return;
	static_cdtp = cdtp;
RETURN:
	return;


     end get_cdt_ptr;


CDT_THREAD_DAMAGE:					/* Code comes here when something is WRONG */
     procedure (n_daughters, muxx, errorx);

declare  n_daughters fixed bin;
declare  muxx fixed bin;
declare  errorx fixed bin;

declare  cdt_mgr_$thread entry (pointer, fixed binary (35));
declare  as_error_table_$repeated_cdt_damage ext static fixed bin (35);
declare  as_error_table_$cdt_rethreading_error ext static fixed bin (35);


	if muxx > 0
	then call error_many (cdt.cdt_entry (muxx).name, muxx, cdt.cdt_entry (errorx).name, errorx,
		cdt.cdt_entry (muxx).daughter_count);
	else if muxx = 0
	then call error_many ("Top level muxes", 0, cdt.cdt_entry (errorx).name, errorx, cdt.threads.daughter_count);
	else call error_many ("FNP " || substr (collate (), rank ("a") - muxx, 1), muxx, cdt.cdt_entry (errorx).name,
		errorx, cdt.fnp_entry (-muxx).daughter_count);
	go to E_COMMON;

CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS:
     entry (n_daughters, muxx);

	if muxx > 0
	then call error_few (cdt.cdt_entry (muxx).name, muxx, cdt.cdt_entry (muxx).daughter_count);
	else if muxx = 0
	then call error_few ("Top level muxes", 0, cdt.threads.daughter_count);
	else call error_few ("FNP " || substr (collate (), rank ("a") - muxx, 1), muxx,
		cdt.fnp_entry (-muxx).daughter_count);
	go to E_COMMON;

CDT_THREAD_DAMAGE$$DAUGHTERS:
     entry (muxx);

	if muxx > 0
	then call error_none (cdt.cdt_entry (muxx).name, muxx, cdt.cdt_entry (muxx).daughter_count,
		cdt.cdt_entry (muxx).daughter);
	else if muxx = 0
	then call error_none ("Top level muxes", 0, cdt.threads.daughter_count, cdt.threads.daughter);
	else call error_none (substr (collate (), rank ("a") - muxx, 1), muxx, cdt.fnp_entry (-muxx).daughter_count,
		cdt.fnp_entry (-muxx).daughter);

CDT_THREAD_DAMAGE$$BRIEF:
     entry;

E_COMMON:
	if thread_trouble_count > 0			/* once is all you get */
	then do;
	     call sys_log_ (1, "^a: Repeated damage to CDT threads encountered.", name);
	     arg_code = as_error_table_$repeated_cdt_damage;
	     go to RETURN;
	end;
	call sys_log_ (1, "^a: Threading inconsistency detected in CDT. Rethreading.", name);
	thread_trouble_count = 1;
	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, sub_error_info.status_code, name, "cdt_mgr_$thread: ^a",
		sub_error_info.info_string);
	     if ^sub_error_info.default_restart		/* not just warning */
	     then do;
		call sys_log_ (1, "^a: Error while rethreading CDT.", name);
		call sys_log_$error_log (3, sub_error_info.status_code, name, "cdt_mgr_$thread: ^a.",
		     sub_error_info.info_string);
		arg_code = as_error_table_$cdt_rethreading_error;
		go to RETURN;
	     end;
	end;

	call cdt_mgr_$thread (cdtp, (0));		/* code uninteresting */

/**** IF WE GOT HERE, IT SUCCEEDED ****/

	call sys_log_ (1, "^a: Rethreading complete.", name);
	if miip ^= null
	then free mux_init_info;
	go to BAD_THREADS_LABEL;

error_many:
	procedure (pname, px, ename, ex, dc);
declare  (pname, ename) character (32) aligned;
declare  dc fixed bin unaligned;
declare  (px, ex) fixed bin;

	     call sys_log_ (1, "^a: ^d daughters found for mux ^a(^d) at ^a(^d), but daughter count is ^d", name,
		n_daughters, pname, px, ename, ex, dc);
	     return;

error_few:
	entry (pname, px, dc);

	     call sys_log_ (1, "^a: ^d daughters found for mux ^a(^d), but daughter count is ^d.", name, n_daughters,
		pname, px, dc);
	     return;

error_none:
	entry (pname, px, dc, d);
declare  d fixed bin unaligned;

	     call sys_log_ (1, "^a: ^a(^d) has daughter count ^d, but first daughter ^d", name, pname, px, dc, d);
	     return;
	end error_many;

     end CDT_THREAD_DAMAGE;


ERROR_EARLY_CALL:
	begin;
	     call sys_log_ (1, "^a: multiplexers may not be manipulated before AS initialization.", name);
	     arg_code = error_table_$action_not_performed;
	     return;
	end;
RETURN:
	return;


init:
     entry (arg_cdtp, arg_code);
	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed
	then call sub_err_ (error_table_$out_of_sequence, "multiplexer_mgr_$init", "s");
	call set_entry_name ("init");
	if static_cdtp ^= null			/* already done some initialization? */
	then do;
	     cdtp = static_cdtp;
	     if cdt.mux_mgr_system_init		/* really got going? */
	     then do;
		call sys_log_ (1, "^a: Shutting down initialized multiplexers prior to re-initialization.", name);
		call shut;			/* try to stop things */
	     end;
	end;					/* NOTE: shut will set static_cdtp = null */
	if static_cdtp = null			/* see if never initialized or just shut */
	then do;
	     call get_cdt_ptr (arg_code);
	     if arg_code ^= 0
	     then return;
	     smlep = stop_mpx_list_ptr_;		/* if this is a retry, then we must */
	     fnp_only = "1"b;			/* re-stop any muxes that were early stopped */
						/* list will be null if not retry */
	     do while (smlep ^= null);		/* for each early-stopped mux */
		mpx_name = stop_mpx_list_entry.mpx_name;
		BAD_THREADS_LABEL = INIT_RE_STOP_MPX;	/* where to go if error & good salvage */
INIT_RE_STOP_MPX:					/* not a million miles away */
		call validate_mpx_name (muxx);	/* is it still there? */
		if code ^= 0			/* qu'elle chomage */
		then call sys_log_$error_log (1, code, name, "Unable to perform requested stop_mpx of ^a.", mpx_name);
		else do;				/* ahhhhh */
		     mpxe.current_service_type = INACTIVE;
		     mpxe.flags.go = "0"b;
		end;
		smlep = stop_mpx_list_entry.next;
	     end;
	end;

	if ^as_data_$lct_initialized
	then do;
	     call hphcs_$lct_init (as_data_$lct_size, arg_code);
						/* Perform ring0 initialization */
	     if arg_code ^= 0
	     then call sys_log_$error_log (1, arg_code, "multiplexer_mgr_$init", "From hphcs_$lct_init");
	     else as_data_$lct_initialized = "1"b;
	end;
	arg_cdtp = static_cdtp;
	arg_code = 0;
	return;

shut:
     entry;
declare  cdt_mgr_$shut entry (pointer);
	if static_cdtp = null
	then return;

	cdtp = static_cdtp;

	call set_entry_name ("shut");
	BAD_THREADS_LABEL = RE_SHUT;			/* see below */

	if loud
	then call sys_log_ (1, "^a: Shutting down all multiplexers.", name);

/* First the FNP's */

	do i = 1 to hbound (cdt.fnp_entry, 1);		/* Start bootload on each fnp */
	     fnpep = addr (cdt.fnp_entry (i));
	     mpxep = addr (fnpe.mpxe);
	     if mpxe.state = MPX_UP | mpxe.state = MPX_BOOT
	     then do;				/* And it is nornally booted */
		mpx_name = substr (collate (), rank ("a") + i, 1);
		call shutdown_mpx (mpx_name, "0"b /* no dump */, code);
		if code ^= 0
		then if loud
		     then call sys_log_$error_log (1, code, name, "Could not shutdown FNP ^a.", mpx_name);
	     end;
	end;

	call thread_start (0 /* ROOT */, firstx, d_limit);
	i = 0;
	do x = firstx repeat (cdt.cdt_entry (x).next_sister) while (x ^= 0);
	     cdtep = addr (cdt.cdt_entry (x));
	     i = i + 1;
	     if i > d_limit | i > cdt.n_cdtes | cdte.mother ^= 0
	     then call CDT_THREAD_DAMAGE (i, 0, x);
	     mpxep = addr (cdte.initial_command);
	     if mpxe.current_service_type = ACTIVE & mpxe.state = MPX_DOWN
	     then do;
		call shutdown_mpx ((cdte.name), "0"b, code);
		if code ^= 0
		then if loud
		     then call sys_log_$error_log (1, code, name, "Could not shutdown ^a.", cdte.name);
	     end;
	end;
	if i < d_limit
	then call CDT_THREAD_DAMAGE$$TOO_FEW_DAUGHTERS (i, 0);


GIVE_UP_SHUT:
	cdt.mux_mgr_system_init = "0"b;


	call cdt_mgr_$shut (static_cdtp);
	static_cdtp = null;
	return;

RE_SHUT:
	BAD_THREADS_LABEL = GIVE_UP_SHUT;		/* only one try */
	thread_trouble_count = 0;			/* but go to give up rather than returning */


/* Entry to count users for reconfiguration */

count_mpx_users:
     entry (arg_mpx_name, arg_cdtp, arg_count, arg_code);

	call set_entry_name ("count_mpx_users");

	mpx_name = arg_mpx_name;
	arg_count = 0;
	if arg_cdtp ^= null ()
	then cdtp = arg_cdtp;
	else cdtp = static_cdtp;
	if cdtp = null | ^cdt.mux_mgr_system_init
	then do;
	     code = error_table_$null_info_ptr;
	     return;
	end;
	BAD_THREADS_LABEL = ABORT_COUNT;

	call validate_mpx_name (muxx);		/* grab this mux */
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	call count_mpx_users (muxx, arg_count);
	return;

ABORT_COUNT:
	arg_code = error_table_$action_not_performed;
	return;



set_loud:
     entry;

	loud = "1"b;
	return;

set_quiet:
     entry;

	loud = "0"b;
	return;
%page;
%include as_data_;
%page;
%include author_dcl;
%page;
%include cdt;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include dialup_values;
%page;
%include event_call_info;
%page;
%include multiplexer_types;
%page;
%include mux_init_info;
%page;
%include net_event_message;
%page;
%include sc_stat_;
%page;
%include sub_error_info;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   multiplexer_mgr_$load_mpx: Loading MPX. ARGS

   S:     as (severity1)

   T:     $run

   M:     A load of the multiplexer named MPX has been started. ARGS,
   if present, lists the control arguments given to the load_mpx
   command (-check, -go, and/or -force).

   A:     $ignore

   Message:
   multiplexer_mgr_$load_mpx: MPX not loaded. Unable to determine the
   state of its parent.

   S:     as (severity1)

   T:     $run

   M:     An attempt to load the multiplexer named MPX failed because
   the system was unable to determine whether its parent multiplexer
   was loaded.

   A:     $inform
   If possible, attempt to load the parent multiplexer.

   Message:
   multiplexer_mgr_$load_mpx: MPX cannot be loaded because its parent
   multiplexer is not running.

   S:     as (severity1)

   T:     $run

   M:     An attempt to load the multiplexer named MPX failed because
   its parent multiplexer was not running.

   A:     Try to load the parent multiplexer before retrying the load
   of MPX.

   Message:
   multiplexer_mgr_$load_mpx: Initialization of MPX already in progress.

   S:     as (severity1)

   T:     $run

   M:     An attempt to load the multiplexer named MPX failed because
   a previous load of MPX has not completed.

   A:     Either allow the load currently in progress to complete, or
   use the dump_mpx command to abort before retrying the load.

   Message:
   multiplexer_mgr_$load_mpx: User(s) of N channel(s) would be hung
   up. MPX not loaded. Use -force if necessary.

   S:     as (severity1)

   T:     $run

   M:     The multiplexer named MPX has N subchannels with users
   logged in. It can only be loaded if the -force control argument is
   provided to the load_mpx command.

   A:     Either reenter the load_mpx command with the -force control
   argument, or wait for the users to be disconnected or logged out.

   Message:
   multiplexer_mgr_$load_mpx: MPX has no subchannels.

   S:     as (severity1)

   T:     $run

   M:     The multiplexer named MPX cannot be used because it has no
   subchannels specified in the CDT.

   A:     $inform_sa

   Message:
   multiplexer_mgr_$load_mpx: No devx assigned to MPX.CHAN.

   S:     as (severity1)

   T:     $run

   M:     The subchannel CHAN of multiplexer MPX was not assigned a
   device index ("devx") when MPX was initialized.

   A:     $inform

   Message:
   multiplexer_mgr_$load_mpx: Unable to init channel CHAN on MPX.

   S:     as (severity1)

   T:     $run

   M:     The subchannel CHAN of multiplexer MPX could not be
   initialized.

   A:     $inform

   Message:
   multiplexer_mgr_$shutdown_mpx: Shutting down MPX. [dump]

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when a multiplexer is
   shut down. The string "dump" appears at the end of the message if
   the the shutdown is in response to a dump_mpx command, rather than a
   shutdown_mpx command.

   A:     $ignore

   Message:
   multiplexer_mgr_$COMMAND: Dumping MPX. [force]

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when dumping a
   multiplexer in response to either a dump_mpx or shutdown_mpx
   command (as indicated by COMMAND). The string "force" appears if
   the -force control argument was specified.

   A:     $ignore

   Message:
   multiplexer_mgr_$COMMAND: User(s) of N channel(s) would be hung up.
   MPX not dumped. Use -force if necessary.

   S:     as (severity1)

   T:     $run

   M:     The multiplexer named MPX had logged-in users on N
   subchannels when a dump_mpx or shutdown_mpx command (as indicated by
   COMMAND) was given. The multiplexer cannot be dumped or shut down
   unless the -force control argument is used.

   A:     Retry the command with the -force control argument, or wait
   for the users to be disconnected or logged out.

   Message:
   multiplexer_mgr_$start_mpx: Starting MPX. [force]

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when the multiplexer
   named MPX is started, either automatically after loading, or in
   response to an explicit start_mpx command. The string "force"
   appears if the -force control argument was specified.

   A:     $ignore

   Message:
   multiplexer_mgr_$start_mpx: MPX has not been loaded, so it can't be
   started.

   S:     as (severity1)

   T:     $run

   M:     A start_mpx command was entered for the multiplexer named
   MPX, but it has not been loaded.

   A:     Load the multiplexer by using the load_mpx command.

   Message:
   multiplexer_mgr_$start_mpx: MPX is already started.

   S:     as (severity1)

   T:     $run

   M:     A start_mpx command was entered for the multiplexer named
   MPX, but it had already been started.

   A:     $ignore

   Message:
   multiplexer_mgr_$start_mpx: MPX is currently loading. It will be
   started when load completes.

   S:     as (severity1)

   T:     $run

   M:     A start_mpx command was entered for the multiplexer named
   MPX while loading of MPX was in progress. The start_mpx command
   will take effect after the load is completed.

   A:     $ignore

   Message:
   multiplexer_mgr_$stop_mpx: Stopping MPX

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears in response to a
   stop_mpx command for the multiplexer named MPX.

   A:     $ignore

   Message:
   multiplexer_mgr_$stop_mpx: MPX is running but no longer accepting calls.

   S:     as (severity1)

   T:     $run

   M:     This message acknowledges that a stop_mpx command has been
   successfully executed on the running multiplexer named MPX.

   A:     $ignore

   Message:
   multiplexer_mgr_$stop_mpx: MPX is now loading, but will not be started

   S:     as (severity1)

   T:     $run

   M:     This message acknowledges a stop_mpx command for the
   multiplexer named MPX, which is currently being loaded.

   A:     $ignore

   Message:
   multiplexer_mgr_$stop_mpx: MPX will not be loaded.

   S:     as (severity1)

   T:     $run

   M:     This message acknowledges a stop_mpx command for the
   multiplexer named  MPX, which is currently not loaded.

   A:     $ignore

   Message:
   multiplexer_mgr_$listen_mpx: Listening to MPX.

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when starting to
   listen to the subchannels of the multiplexer named MPX after it has
   been loaded and started.

   A:     $ignore

   Message:
   multiplexer_mgr_$listen_mpx: MPX is not running. Unable to listen
   to channels.

   S:     as (severity1)

   T:     $run

   M:     An attempt was made to listen to the subchannels of the
   multiplexer named MPX, but the multiplexer was not running. This
   might occur if the multiplexer crashed very shortly after being
   loaded.

   A:     If there is a message indicating that the multiplexer
   crashed shortly after loading, try to reload it. Otherwise, contact
   the system programming staff.

   Message:
   multiplexer_mgr_$listen_mpx: asu_$listen_chanel failed for MPX.CHAN.

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears if an attempt to
   listen to the subchannel named CHAN of the multiplexer named MPX
   returned a status code of error_table_$action_not_performed. An
   additional message from asu_$asu_listen should appear giving more
   information about the failure.

   A:     $inform

   Message:
   multiplexer_mgr_mpx_loaded: Successful load reported for MPX.

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when the answering
   service is notified that the multiplexer named MPX has been
   successfully loaded.

   A:     $ignore

   Message:
   multiplexer_mgr_$mpx_load_failed: Report load failure for MPX while
   not loading.

   S:     as (severity1)

   T:     $run

   M:     The answering service was notified that loading of the
   multiplexer named MPX had failed, but no load of that multiplexer
   was in progress at the time.

   A:     $inform

   Message:
   multiplexer_mgr_$mpx_load_failed: Load of MPX failed.

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears if the answering
   service is notified that an attempt to load the multiplexer named
   MPX failed. A previous message should give more information about
   the failure.

   A:     $ignore

   Message:
   multiplexer_mgr_$mpx_crashed: Crash reported for MPX.

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when the answering
   service is notified that the multiplexer named MPX has crashed.

   A:     $ignore

   Message:
   multiplexer_mgr_$mpx_crashed: MPX is stopped and will not be reloaded.

   S:     as (severity1)

   T:     $run

   M:     The multiplexer named MPX has crashed and is not being
   reloaded because of a previous stop_mpx command.

   A:     $ignore

   Message:
   multiplexer_mgr_$mpx_crashed: Automatic reloading is disabled. MPX
   will not be reloaded.

   S:     as (severity1)

   T:     $run

   M:     The multiplexer named MPX, which has crashed, is not being
   reloaded because automatic reloading of multiplexers has been
   disabled (by setting the FNP_required_up_time field in the CMF to
   0).

   A:     If it is desired to reload the multiplexer, enter a load_mpx
   command.

   Message:
   multiplexer_mgr_$mpx_crashed: MPX is in apparent crash loop and
   will not be reloaded

   S:     as (severity1)

   T:     $run

   M:     The multiplexer named MPX has crashed more than twice in the
   interval specified by FNP_required_up_time, and will not be
   automatically reloaded.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: Command used too early in answering service
   initialization. MPX

   S:     as (severity1)

   T:     $run

   M:     An operator command (identified by CMD) has been entered for
   the multiplexer named MPX before the answering service has been
   initialized.

   A:     $ignore
   The command may have to be entered manually after answering service
   initialization is complete.

   Message:
   ERROR. cdt_mgr_$find_cdt_channel: INFO

   S:     as (severity1)

   T:     $run

   M:     An error (identified by the status code reported in ERROR)
   has occurred while trying to find a multiplexer name in the CDT.
   Further information about the error is given in INFO.

   A:     $inform

   Message:
   multiplexer_mgr_$validate_mpx_name: Invalid multiplexer name: MPX REASON

   S:     as (severity1)

   T:     $run

   M:     The multiplexer name MPX, which has been used in an operator
   command, is invalid, for the reason given by REASON.

   A:     If the name was mistyped, reenter the command. Otherwise,
   contact the system administrator.

   Message:
   multiplexer_mgr_$CMD: Rethreading CDT.

   S:     as (severity0)

   T:     $run

   M:     In the process of performing the action requested by CMD,
   the CDT was found to be damaged (as indicated by a separate
   message); an attempt will be made to repair the damage.

   A:     $ignore

   Message:
   multiplexer_mgr_$CMD: Rethreading of CDT complete.

   S:     as (severity0)

   T:     $run

   M:     Damage to the CDT discovered in the course of executing CMD,
   and reported in a previous message, has been successfully repaired.

   A:     $ignore

   Message:
   multiplexer_mgr_$CMD: CDT rethreading failed.

   S:     as (severity2)

   T:     $run

   M:     An attempt to repair damage to the CDT discovered while
   executing CMD (and reported in a previous message) has failed.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: Threading inconsistency detected in CDT.
   Rethreading.

   S:     as (severity1)

   T:     $run

   M:     An inconsistency in the CDT has been discovered in the CDT
   while executing CMD. An attempt will be made to repair the
   inconsistency.

   A:     $ignore

   Message:
   multiplexer_mgr_$CMD: Repeated damage to CDT threads encountered.

   S:     as (severity1)

   T:     $run

   M:     After an attempt to repair an inconsistency to the CDT
   discovered while executing CMD, the CDT was still inconsistent.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: Error while rethreading CDT.

   S:     as (severity1)

   T:     $run

   M:     An error (reported by a previous message) was encountered
   while attempting to repair an inconsistency in the CDT discovered
   while executing CMD.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: Rethreading complete.

   S:     as (severity1)

   T:     $run

   M:     An inconsistency discovered in the CDT while executing CMD
   (and reported in a previous message) has been successfully repaired.

   A:     $ignore

   Message:
   multiplexer_mgr_$CMD: N daughters found for mux MPX(X1)[ at
   CHAN(X2]), but daughter count is M

   S:     as (severity1)

   T:     $run

   M:     An inconsistency in the CDT was found while executing CMD.
   The CDT indicates that the multiplexer named MPX, occupying entry
   number X1, has M subchannels, but N subchannels are threaded to it.
   If N > M, the Nth subchannel is CHAN, occupying entry number X2.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: MPX(X1) has daughter count N, but first
   daughter X2

   S:     as (severity1)

   T:     $run

   M:     An inconsistency has been discovered in the CDT while
   executing CMD. The multiplexer named MPX, occupying CDT entry X1,
   is marked as having N subchannels, but the first subchannel entry
   number is X2, where either N or X2, but not both, is 0.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: multiplexers may not be manipulated before AS
   initialization.

   S:     as (severity1)

   T:     $run

   M:     An attempt was made to execute the command CMD before the
   answering service was initialized.

   A:     $ignore
   It may be necessary to reenter the command after answering service
   initialization is complete.

   Message:
   multiplexer_mgr_$init: Shutting down initialized multiplexers prior
   to re-initialization.

   S:     as (severity1)

   T:     $run

   M:     Multiplexer management is being reinitialized after some
   multiplexers had been loaded. Such multiplexers will be shut down
   prior to reinitialization.

   A:     $ignore

   Message:
   multiplexer_mgr_$shut: Shutting down all multiplexers.

   S:     as (severity1)

   T:     $run

   M:     If tracing is on, this message appears when multiplexers are
   being shut down as part of system shutdown or when an error was
   encountered during answering service initialization.

   A:     $ignore

   Message:
   multiplexer_mgr_$load_mpx: ERROR. Unable to get a devx for MPX

   S:     as (severity1)

   T:     $run

   M:     An error code (described by ERROR) has been returned from an
   attempt to find the device index ("devx") of the multiplexer named
   MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$load_mpx: ERROR. Unable to initialize MPX.

   S:     as (severity1)

   T:     $run

   M:     An error code (described by ERROR) hs been returned from an
   attempt to initialize the multiplexer named MPX in ring 0.

   A:     $inform

   Message:
   multiplexer_mgr_$load_mpx: ERROR. Unable to load MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) has prevented the loading of
   the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$shutdown_mpx: ERROR. Shutting down MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) has occurred when attempting
   to shut down the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$shutdown_mpx: ERROR. Unable to dump MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) has occurred when attempting
   to dump the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$shutdown_mpx: ERROR. Terminating MPX.CHAN.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) has occurred while terminating
   the subchannel CHAN of the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$shutdown_mpx: ERROR. Terminating MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) has occurred when attempting
   to terminate the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$start_mpx: ERROR. Can't get devx for MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) was returned from an attempt
   to get the device index ("devx") for the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$start_mpx: ERROR. Starting MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) occurred when attempting to
   start the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$stop_mpx: ERROR. Can't get devx for MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) was returned from an attempt
   to get the device index ("devx") for the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$stop_mpx: ERROR. Unable to stop MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) occurred when attempting to
   stop the multiplexer named MPX.

   A:     $inform

   Message:
   multiplexer_mgr_$listen_mpx: ERROR. asu_$attach_channel failed MPX.CHAN

   S:     as (severity1)

   T:     $run

   M:     An error was returned by asu_$attach_channel when attempting
   to attach the subchannel CHAN while listening to all subchannels of
   the multiplexer named MPX. This message only appears if tracing is
   on.

   A:     $inform

   Message:
   multiplexer_mgr_$listen_mpx: ERROR. Channel MPX.CHAN listen failed.

   S:     as (severity1)

   T:     $run

   M:     An attempt to listen to the subchannel CHAN of the
   multiplexer MPX encountered an error (described by ERROR).

   A:     $inform

   Message:
   multiplexer_mgr_$mpx_load_failed: ERROR. Trying to shutdown MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) occurred when attempting to
   shut down the multiplexer named MPX after it had failed to load.

   A:     $inform

   Message:
   multiplexer_mgr_$mpx_crashed: ERROR. Shutting down MPX

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) occurred when attempting to
   shut down the multiplexer named MPX after it had crashed.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: ERROR. cdt_mgr_$init: INFO

   S:     as (severity0)

   T:     $run

   M:     An error (described by ERROR, with additional information in
   INFO) occurred while trying to get a pointer to the CDT in order to
   execute the command named CMD.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: ERROR. cdt_mgr_$thread: INFO

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR, with additional information in
   INFO) occurred while trying to repair damage to the CDT discovered
   while executing CMD.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: ERROR. cdt_mgr_$init failed.

   S:     as (severity1)

   T:     $run

   M:     An error (desribed by ERROR) occurred when trying to
   initialize the CDT in preparation for executing CMD.

   A:     $inform

   Message:
   multiplexer_mgr_$CMD: ERROR. cdt_mgr_$thread: INFO

   S:     as (severity3)

   T:     $run

   M:     An error (described by ERROR, with additional information in
   INFO) occurred while trying to repair damage to the CDT discovered
   while executing CMD; the attempt at repair will not be repeated.

   A:     $inform

   Message:
   multiplexer_mgr_$init: ERROR. Unable to perform requested stop_mpx of MPX.

   S:     as (severity1)

   T:     $run

   M:     An attempt to shut down the multiplexer named MPX, while
   reinitializing multiplexer management, encountered an error
   (described by ERROR).

   A:     $inform

   Message:
   multiplexer_mgr_$init: ERROR. From hphcs_$lct_init

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) was returned from
   hphcs_$lct_init while trying to initialize multiplexer management.

   A:     $inform

   Message:
   multiplexer_mgr_$shut: ERROR. Could not shutdown FNP X.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) occurred when trying to shut
   down the FNP named X during system shutdown or after an error in
   answering service initialization.

   A:     $inform

   Message:
   multiplexer_mgr_$shut: ERROR. Could not shutdown MPX.

   S:     as (severity1)

   T:     $run

   M:     An error (described by ERROR) occurred when trying to shut
   down the multiplexer named MPX during system shutdown or after an
   error in answering service initialization.

   A:     $inform



   END MESSSAGE DOCUMENTATION */
     end multiplexer_mgr_;




		    reassign_work_classes_.pl1      07/13/88  1112.8r w 07/13/88  0938.5      133956



/****^  ***********************************************************
        *                                                         *
        * 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 */
reassign_work_classes_: proc (a_code);

/* This procedure set the work_class of each process to the
   proper value for the current shift, and defines the set of work_classes
   which are to be in effect for the current shift.  It is called by the
   Answering Service process at shift change time and whenever a new
   master_group_table (MGT) is installed or the operator executes the
   "maxu auto" command". */

/* Last modified date & reason: */
/* Coded July 8, 1975 by RE Mullen for Priority Scheduler */
/* Mod by RE Mullen, Summer '76 for Deadline Scheduler */
/* Modified May 1981, E. N. Kittlitz, assign daemons according to interactive specification */
/* Modified July 1981 by J. Bongiovanni for max_pct (governed work classes) */
/* Modified November 1981, E. N. Kittlitz.  user_table_entry conversion. */
/* Modified May 1982, E. N. Kittlitz. New AS initialization. */

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(87-03-11,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,Hartogs), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.  Support AS test mode by suppressing
     some operations when invoked in a test AS.
  3) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,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 */

dcl  a_code fixed bin (35);

dcl  ALL_IN_ONE bit (1) aligned;			/* "1"b => all processes go in first workclass */
dcl  code fixed bin (35);
dcl  curshift fixed bin;
dcl  force_compromise bit (1) aligned;			/* "1"b => call DEFINE_COMPROMISE if trouble */
dcl  i fixed bin;

dcl  1 new_wci like work_class_info aligned;

dcl  hphcs_$define_work_classes entry (ptr, fixed bin (35));
dcl  hphcs_$set_process_work_class entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  sys_log_ entry options (variable);

dcl (default_r1 init (4000000),			/* 4 seconds */
     default_q1 init (500000),			/* half second */
     default_r2 init (32000000),			/* 32 seconds */
     default_q2 init (1000000)) fixed bin (35) int static options (constant); /* one second */

dcl (error_table_$action_not_performed,
     error_table_$bad_processid,
     error_table_$bad_work_class) ext static fixed bin (35);

dcl  (addr, null, unspec) builtin;

/* END DCL */

/* First copy static pointers into automatic. */

	ansp = as_data_$ansp;
	autp = as_data_$autp;
	dutp = as_data_$dutp;

	code = 0;					/* Zero status code for now */

/* Make sure we know about this kind of MGT */

	if mgt.version_indicator ^= "VERSION " then go to MAIN_RETURN;
	else if mgt.version < MGT_version_3 - 1 then go to MAIN_RETURN;

/* Make sure priority scheduler exists. */

	if mgt.switches.prio_sked_on_tape = "0"b then go to MAIN_RETURN; /* If not, forget it. */

/* Now get the current shift. */

	curshift = anstbl.shift;


/* Gather info about new work_classes into new_wci structure. */
/* This will be used (but not modified) by GET_WC */
/* Later new_wci will be passed to the hardcore. */

	unspec (new_wci) = ""b;			/* clear structure */
	new_wci.version = WCI_version_3;
	new_wci.set_user_wc = "1"b;

	ALL_IN_ONE = "1"b;				/* Assume no workclasses defined. */

	if mgt.prio_sked_enabled then do;		/* There might be some defined. */
	     do i = 1 to 16;
		mgtep = addr (mgt.entry (i));
		new_wci.user_wc_defined (i) = work_class.defined (curshift);
		if new_wci.user_wc_defined (i) = "1"b then ALL_IN_ONE = "0"b;
		new_wci.user_wc_min_pct (i) = work_class.min_pct (curshift);
	     end;
	     if ALL_IN_ONE then do;			/* No wc defined, should've been. */
		call sys_log_ (2, "reassign_work_classes_: no work classes defined on current shift.");
	     end;
	end;

	if ALL_IN_ONE then do;			/* No wc defined or not to enable priosked. */
	     do i = 1 to 16;
		if i = 1 then do;
		     new_wci.user_wc_defined (i) = "1"b;/* only first defined. */
		     new_wci.user_wc_min_pct (i) = 100; /* Has whole machine. */
		end;
		else do;
		     new_wci.user_wc_defined (i) = "0"b;
		     new_wci.user_wc_min_pct (i) = 0;
		end;
	     end;
	end;

	do i = 1 to 16;				/* set at least default deadlines */
	     mgtep = addr (mgt.entry (i));		/* get ptr to workclass */
	     if mgt.version >= MGT_version_3		/* can use admin specified */
		& ^ALL_IN_ONE
		& mgt.prio_sked_enabled
		& new_wci.user_wc_defined (i) then do;
						/* one 1/100 sec = 10000 microsec */
		new_wci.resp1 (i) = 10000 * work_class.int_response (curshift);
		new_wci.quantum1 (i) = 10000 * work_class.int_quantum (curshift);
		new_wci.resp2 (i) = 10000 * work_class.response (curshift);
		new_wci.quantum2 (i) = 10000 * work_class.quantum (curshift);
		new_wci.realtime (i) = work_class.realtime (curshift);
		new_wci.governed (i) = (work_class.max_pct (curshift) > 0);
		new_wci.user_wc_max_pct (i) = work_class.max_pct (curshift);
	     end;
	     else do;				/* use defaults */
		new_wci.resp1 (i) = default_r1;
		new_wci.quantum1 (i) = default_q1;
		new_wci.resp2 (i) = default_r2;
		new_wci.quantum2 (i) = default_q2;
		new_wci.governed (i) = "0"b;
		new_wci.user_wc_max_pct (i) = 0;
	     end;
	end;

	if mgt.version >= MGT_version_3 & mgt.prio_sked_enabled then do;
	     new_wci.set_sked_mode = "1"b;
	     new_wci.deadline_mode = mgt.deadline_mode (curshift);
	end;

/* Compute new value of workclass for each user now logged in. */
/* Note: GET_WC will verify that the work_class will be defined. */

	mgtep = addr (mgt.entry (17));		/* Initialize GET_WC's assoc mem */

	do i = 1 to anstbl.current_size;
	     utep = addr (anstbl.entry (i));		/* get ptr to answer table entry */
	     call GET_WC;
	end;

	do i = 1 to dutbl.current_size;
	     utep = addr (dutbl.entry (i));		/* get ptr to daemon table entry */
	     call GET_WC;
	end;

	do i = 1 to autp -> autbl.current_size;
	     utep = addr (autp -> autbl.entry (i));	/* get ptr to autbl entry */
	     call GET_WC;
	end;


/* We now know that it is indeed possible to move all users
   to their new work_class and define a new set of work classes.
   There should be no furthur errors.  If there are
   it implies either somebody else is calling the hardcore in which case
   this procedure can be called again and probably succeed, or
   something is busted in which case we can be called again and fail. */

/* Define an all-inclusive set of work classes. */

	call DEFINE_COMPROMISE;


/* Move all users to new work_classes */

	force_compromise = "1"b;
	call MOVE_USERS;


/* Define new set of work classes. */

	if ^as_data_$debug_flag then do;
	     call hphcs_$define_work_classes (addr (new_wci), code);
	     if code ^= 0 then do;
		if new_wci.error_process_id ^= ""b then do; /* Point finger at guilty one. */
		     call sys_log_ (1, "reassign_work_classes_: process ^w remained in work class ^d.",
			new_wci.error_process_id, new_wci.error_work_class);
		end;
	     end;
	     go to MAIN_RETURN;
	end;


/* Force hardcore to rethread with new work_class definitions extant */

	force_compromise = "0"b;			/* no use compromise if swc fails */
	call MOVE_USERS;


/* Now reflect new work classes in mgt header. */

	mgt.user_wc_defined (*) = new_wci.user_wc_defined (*);
	mgt.user_wc_min_pct (*) = new_wci.user_wc_min_pct (*);


MAIN_RETURN:					/* Come here to return to caller */
	a_code = code;
	return;					/* return from main proc here if not sooner */



/* ==================================================================== */

GET_WC: proc;					/* IP to set ate.work_class from ate.group & mgt */

dcl  j fixed bin;
dcl  wc fixed bin;
	if ute.active >= NOW_HAS_PROCESS then do;
	     if ute.proc_id = anstbl.as_procid then return; /* Dont bother Initializer */

	     if ALL_IN_ONE then do;			/* Want all users in first work_class */
		wc = 1;				/* So be it. */
	     end;
	     else do;
		if ute.group ^= group.group_id then do; /* do lookup if grp not same as prev. */
		     do j = 17 to mgt.current_size;
			mgtep = addr (mgt.entry (j));
			if ute.group = group.group_id then go to gwc_got_grp;
		     end;
						/* here we should not be */
		     call sys_log_ (2, "reassign_work_classes_: load control group ""^a"" not found in mgt for user ^a.^a.^a.",
			ute.group, ute.person, ute.project, ute.tag);
		     go to gwc_abort;
		end;

gwc_got_grp:
		if ute.queue <= 0			/* Pick up new wc from approp place */
		then wc = group.int_wc (curshift);
		else wc = group.abs_wc (curshift);


		if new_wci.user_wc_defined (wc) = "0"b then do; /* Trouble */
		     call sys_log_ (2, "reassign_work_classes_: undefined work_class ^d required by load_control_group ^a", wc, ute.group);
gwc_abort:
		     call sys_log_ (2, "reassign_work_classes_: mgt clobbered, contact system administrator.");
		     code = error_table_$action_not_performed;
		     go to MAIN_RETURN;		/* Abort now. */
		end;
	     end;

	     ute.work_class = wc;			/* Tell rest of Answering Service */

	end;
     end GET_WC;

/* ================================================================ */


MOVE_USERS: proc;


/* Move all users with processes to new work_classes. */

	do i = 1 to anstbl.current_size;
	     utep = addr (anstbl.entry (i));		/* get ptr to answer table entry */
	     call SET_WC;
	end;

	do i = 1 to dutbl.current_size;
	     utep = addr (dutbl.entry (i));		/* get ptr to daemon table entry */
	     call SET_WC;
	end;


	do i = 1 to autp -> autbl.current_size;
	     utep = addr (autp -> autbl.entry (i));	/* get ptr to autbl entry */
	     call SET_WC;
	end;


     end MOVE_USERS;


/* ========================================================== */


SET_WC: proc;					/* IP to set hardcore wc from ate.work_class */

dcl  wc fixed bin;
dcl  old_wc fixed bin;

	if ute.active >= NOW_HAS_PROCESS then do;	/* Tell hardcore */

	     if ute.proc_id = anstbl.as_procid then return; /* Dont bother Initializer */

	     wc = ute.work_class;
	     if ^as_data_$debug_flag then do;
		call hphcs_$set_process_work_class (ute.proc_id, wc, old_wc, code);
		if code = 0 then ;
		else if code = error_table_$bad_work_class then do; /* Somebody undid compromise set */
		     if ^force_compromise then go to MAIN_RETURN; /* have failed */
		     call DEFINE_COMPROMISE;		/* Willing to retry this once */
		     call hphcs_$set_process_work_class (ute.proc_id, wc, old_wc, code);
		     if code ^= 0 then
			go to MAIN_RETURN;
		end;
		else if code = error_table_$bad_processid then
		     code = 0;			/* So What. */
		else				/* New errcode invented? */
		     go to MAIN_RETURN;
	     end;
	end;


     end SET_WC;
%page;
DEFINE_COMPROMISE: proc;				/* IP to define all 16 work classes */

dcl  dci fixed bin;


dcl  1 com_wci like work_class_info aligned;

	unspec (com_wci) = ""b;			/* clear structure */
	com_wci.set_user_wc = "1"b;			/* set user work classes */
	com_wci.set_sked_mode = "1"b;			/* Force the mode, */
	com_wci.deadline_mode = "0"b;			/* to percent mode for safety */
	do dci = 1 to 16;
	     com_wci.user_wc_defined (dci) = "1"b;	/* all user wc will be defined */
	     com_wci.user_wc_min_pct (dci) = 6;		/* each wc given 6% */
	     com_wci.resp1 (dci) = default_r1;
	     com_wci.quantum1 (dci) = default_q1;
	     com_wci.resp2 (dci) = default_r2;
	     com_wci.quantum2 (dci) = default_q2;
	     com_wci.realtime (dci) = "0"b;
	     com_wci.governed (dci) = "0"b;
	     com_wci.user_wc_max_pct (i) = 0;
	end;
	com_wci.version = WCI_version_3;		/* set version number */

	if ^as_data_$debug_flag then do;
	     call hphcs_$define_work_classes (addr (com_wci), code);
	     if code ^= 0 then do;			/* Heads will roll. */
		go to MAIN_RETURN;
	     end;
	end;

     end DEFINE_COMPROMISE;

%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include dialup_values;
%page; %include daemon_user_table;
%page; %include mgt;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include work_class_info;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   reassign_work_classes_: load control group "XXX" not found in mgt for user PERSON.PROJECT.TAG.
   .br
   reassign_work_classes_: mgt clobbered, contact system administrator.

   S:	as (severity2).

   T:	At shift change time, or after a "maxu auto" command.

   M:	Some logged in user's load control group has apparently disappeared
   from the mgt.  If the load control group specified in the message is valid, then
   the mgt has been destroyed.  Otherwise, the user's answer table entry
   has been destroyed.  All users will remain in their current work classes.

   A:	$contact_sa


   Message:
   reassign_work_classes_: undefined work class DD required by load control group XXX
   .br
   reassign_work_classes_: mgt clobbered, contact system administrator.

   S:	as (severity2)

   T:	At shift change time, or after a "maxu auto" command.

   M:	There is an inconsistency in the mgt.  Probably the mgt has been destroyed.
   All users will remain in their current work class.

   A:	$contact_sa


   Message:
   reassign_work_classes_: process NNN remained in work class NN

   S:	as (severity1)

   T:	At shift change time, or after a "maxu auto" command.

   M:	Some privileged user has interfered with the Answering Service's
   attempt to define a new set of work classes.  The Answering Service will
   automatically retry the reassignment of work classes.

   A:	$ignore


   Message:
   reassign_work_classes_: no work classes defined on current shift.

   S:	as (severity2)

   T:	At shift change time, or after a "maxu auto" command.

   M:	The table in the mgt that should define the work classes for the
   current shift has not been filled in.  Probably a new shift has been added to
   the installation_parms segment, but the work classes for that shift have
   not been specified in the mgt.  All users will be placed in a single work class.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end reassign_work_classes_;





		    syserr_log_man_.pl1             08/05/87  0800.0r   08/04/87  1540.6      334314



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */



/****^  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.
                                                   END HISTORY COMMENTS */


/* *	SYSERR_LOG_MAN_
   *
   *	Entry points to manage automatic copying of syserr log
   *	into ring 4 by Initializer process.
   *
   *	Modification history:
   *	75-10-28, LJS: Rewritten to use iox_/vfile_
   *	76-04-15, LJS: Modified for minor bugs
   *	79-02-01, T. Casey: Modified to print bad args if ring 0 rejects them
   *	79-05-06, T. Casey: Modified to check for message time in future when copying from LOG partition.
   *	81-06-15, T. Casey: Modified for MR9.0 for new wakeup priorities.
   *	81-11-20, E. N. Kittlitz:  Modified for user_table_entry conversion.
   *	82-05-02, E. N. Kittlitz: New AS initialization
   *	82-09-14, E. N. Kittlitz: Quick fix: allow init after startup
   *	82-10-28, E. N. Kittlitz: Fixup ucs.
   *	84-10-15, W. Olin Sibert: Rewritten for new log management
   *	84-10-16, WOS: Changed to create >sc1>syserr_log if not there already
   *	84-11-11, WOS: Changed to do syserr message recovery for mc_con_rec_
   *	84-11-11, WOS: Changed to do syserrlog_segdamage_scan_ work, too.
   *	84-12-14, WOS: Changed to be more polite about announcing thresholds
   *	85-02-20, EJ Sharpe: changed segdamage scan code to use real data class
   *		instead of first word of binary.  Also fix references to (write alarm)_flags masks.
   *	85-03-01, EJ Sharpe: fix as_copy_log to set new timer only when invoked by a timer
   *		also insert "verify_sequence" subroutine
*/

/* format: style4 */

syserr_log_man_:
     procedure ();

declare  P_log_name char (*) parameter;			/* OBSOLETE */
declare  P_page_threshold fixed bin parameter;		/* Pages outstanding */
declare  P_copy_interval fixed bin (71) parameter;	/* Microseconds */
declare  P_recovery_flag bit (1) aligned parameter;	/* For turning syserr recovery on/off */
declare  P_recovery_limit fixed bin (35) parameter;	/* First message we have to recover */

declare  1 copy_start aligned automatic,		/* Metering info structure */
	 2 time fixed bin (71),
	 2 vcpu fixed bin (71),
	 2 pf fixed bin (35);
declare  1 copy_finish aligned automatic like copy_start;


declare  1 static aligned internal static,		/* Static info for copying */
	 2 initialized bit (1) aligned init ("0"b),	/* Set after parameters initialized */
	 2 disabled bit (1) aligned init ("0"b),	/* If true, an error occurred, and copying was disabled */

	 2 channel fixed bin (71) init (0),		/* Event channel for signalling copies */
	 2 interval fixed bin (71) init (0),		/* Number of seconds between timed copies (or zero) */
	 2 threshold fixed bin init (0),		/* Number of pages filled between signals from ring 0 */

	 2 total_copies fixed bin (35) init (0),	/* Total number of calls to $as_copy_log */
	 2 null_copies fixed bin (35) init (0),		/* Total number of copy attempts where the log was empty */
	 2 timed_copies fixed bin (35) init (0),	/* Total number of copys invoked by alarm timer */
	 2 total_messages fixed bin (35) init (0),	/* Total number of messages copied */
	 2 meters aligned like copy_start;		/* Time & PF meters for copying */


/* NOTE: This flag is declared separately, so it will not be reset if AS log
   copying is restarted while console recovery is active. */

declare  static_recovery_flag bit (1) aligned internal static init ("0"b);
declare  static_recovery_limit fixed bin (35) internal static init (0);


declare  argl fixed bin (21);
declare  argp pointer;
declare  code fixed bin (35);
declare  current_log_empty bit (1) aligned;
declare  log_write_data_ptr pointer;
declare  n_args fixed bin;

declare  based_char8 char (8) based;
declare  based_ptr pointer based;

declare  error_table_$no_m_permission fixed bin (35) external static;
declare  error_table_$noentry fixed bin (35) external static;
declare  error_table_$notadir fixed bin (35) external static;

declare  log_data_$syserr_log_dir char (168) external static;
declare  log_data_$syserr_log_history_dir char (168) external static;
declare  log_data_$syserr_log_name char (32) external static;

declare  arg_count_ entry options (variable);
declare  as_any_other_handler_ entry (char (*), entry, label, label);
declare  as_any_other_handler_$no_cleanup entry (char (*), label);
declare  as_dump_ entry (char (*));
declare  binary_segmsg_util_ entry (pointer) returns (char (250));
declare  binary_segmsg_util_$interpret_pvname entry (pointer) returns (char (32));
declare  cpu_time_and_paging_ entry (fixed bin (35), fixed bin (71), fixed bin (35));
declare  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
declare  cu_$level_get entry (fixed bin (3));
declare  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
declare  get_group_id_$tag_star entry () returns (char (32));
declare  get_system_free_area_ entry () returns (ptr);
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  hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
declare  hcs_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin (3), bit (36) aligned, bit (36) aligned, fixed bin (35));
declare  hcs_$replace_dir_acl entry (char (*), char (*), pointer, fixed bin, bit (1), fixed bin (35));
declare  hcs_$replace_inacl entry (char (*), char (*), pointer, fixed bin, bit (1), fixed bin (3), fixed bin (35));
declare  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
declare  hcs_$terminate_noname entry (pointer, fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
declare  ioa_ entry options (variable);
declare  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
declare  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, pointer, fixed bin, fixed bin (35));
declare  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
declare  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
declare  log_initiate_ entry (char (*), char (*), fixed bin, pointer, fixed bin (35));
declare  log_list_history_$single_dir entry (char (*), char (*), pointer, fixed bin (35));
declare  log_move_$message entry (pointer, pointer, pointer, fixed bin (35));
declare  log_name_$name entry (char (*), fixed bin (71)) returns (char (32));
declare  log_position_$next_message entry (pointer, pointer, bit (1) aligned);
declare  log_write_$close entry (pointer, fixed bin (35));
declare  log_write_$open_for_migrate entry (char (*), char (*), bit (1) aligned, pointer, fixed bin (35));
declare  mc_con_rec_$queue_log_message entry (pointer, bit (1) aligned);
declare  sys_log_ entry () options (variable);
declare  sys_log_$error_log entry () options (variable);
declare  syserr_log_man_$as_copy_log entry ();
declare  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
declare  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
declare  unique_chars_ entry (bit (*)) returns (char (15));

declare  hphcs_$new_syserr_copy_init entry (fixed bin (71), fixed bin);
declare  hphcs_$new_syserr_info entry (fixed bin (71), bit (1) aligned);
declare  hphcs_$new_syserr_swap_logs entry (fixed bin (35));
declare  hphcs_$new_syserr_reuse_log entry (fixed bin (35));
declare  hphcs_$new_syserr_recovery entry (bit (1) aligned);
declare  hphcs_$new_syserr_verify_sequence entry (fixed bin (35), fixed bin (35), fixed bin (35));
declare  WHOAMI char (32) internal static options (constant) init ("syserr_log_man_");
declare  RELATIVE_SECONDS bit (2) internal static options (constant) init ("11"b);
declare  ONE_MINUTE fixed bin (35) internal static options (constant) init (60);
declare  ONE_DAY fixed bin (35) internal static options (constant) init (86400);
declare  DEFAULT_PAGE_THRESHOLD fixed bin internal static options (constant) init (10);
declare  DEFAULT_COPY_INTERVAL fixed bin (35) internal static options (constant) init (3600); /* One hour */

declare  any_other condition;
declare  cleanup condition;

declare  (addr, binary, clock, dimension, float, mod, null, substr, unspec) builtin;
%page;

syserr_log_man_$as_copy_init:
     entry (P_log_name, P_page_threshold);

/* COMPATIBILITY ENTRYPOINT: Supplies default value for time interval */

	call syserr_log_man_$start_copying (P_page_threshold, (60 * 60));
	return;



syserr_log_man_$restart_copying:
     entry ();

/* Entrypoint to restart after errors */

	call syserr_log_man_$start_copying ((static.threshold), (static.interval));
	return;



syserr_log_man_$console_recovery:
     entry (P_recovery_flag, P_recovery_limit);

/* This entrypoint, called only by mc_con_rec_, is called to turn on the
   syserr_log_man_ message printing/routing mechanism */

	static_recovery_flag = P_recovery_flag;
	static_recovery_limit = P_recovery_limit;

	call hphcs_$new_syserr_recovery (static_recovery_flag);

	return;
%page;

syserr_log_man_$start_copying:
     entry (P_page_threshold, P_copy_interval);

/* This entrypoint initializes the log copying mechanism, setting up the
   static channel name and other information */


	if ^sc_stat_$Multics_typed then do;
	     call sys_log_ (SL_LOG_BEEP, "^a: Called too early.", WHOAMI);
	     return;
	end;

	on condition (any_other)
	     call as_any_other_handler_$no_cleanup (WHOAMI, INIT_ERROR_EXIT);

	static.disabled = "1"b;			/* Make it appear off */

	if (static.channel ^= 0) then			/* Stop it if it's happening now */
	     call stop_copying ("0"b);

	call create_ipc_channel ();

	call set_threshold_values ();

	call get_history_dir ();

	call verify_sequence ();

	static.disabled = "0"b;			/* Nothing has gone wrong */

	call syserr_log_man_$as_copy_log ();		/* Get the copying started */

	if (static.threshold ^= 0) then		/* This signal comes from ring zero */
	     call hphcs_$new_syserr_copy_init (static.channel, static.threshold);

	if (static.interval ^= 0) then
	     call timer_manager_$alarm_wakeup (static.interval, RELATIVE_SECONDS, static.channel);

	static.initialized = "1"b;			/* OK to copy now */

INIT_ERROR_EXIT:
	return;
%page;

create_ipc_channel:
     procedure ();

	call ipc_$create_ev_chn (static.channel, code);	/* Create copying event channel */
	if (code ^= 0) then do;
INIT_IPC_CHANNEL_ERROR:
	     call sys_log_$error_log (SL_LOG, code, WHOAMI,
		"Could not create event channel.^/Automatic syserr log copying not initialized.");
	     call as_dump_ (WHOAMI);
	     call stop_copying ("1"b);
	     goto INIT_ERROR_EXIT;
	end;

	call ipc_$decl_ev_call_chn (static.channel,
	     syserr_log_man_$as_copy_log, null (), SYSERR_COPY_PRIO, code);
	if (code ^= 0) then
	     goto INIT_IPC_CHANNEL_ERROR;

	return;
     end create_ipc_channel;
%page;

set_threshold_values:
     procedure ();

declare  threshold_comment char (40) varying;
declare  interval_comment char (40) varying;


	if (P_page_threshold > 0) & (P_page_threshold < 128) then do;
	     static.threshold = P_page_threshold;
	     threshold_comment = "";
	end;

	else if (P_page_threshold = -1) then do;	/* No copying */
	     static.threshold = 0;
	     threshold_comment = " (disabled)";
	end;

	else do;
	     static.threshold = DEFAULT_PAGE_THRESHOLD;
	     if (P_page_threshold = 0) then
		threshold_comment = " (default)";
	     else threshold_comment = " (installation_parm value invalid)";
	end;

	if (P_copy_interval >= ONE_MINUTE) & (P_copy_interval <= ONE_DAY) then do;
	     static.interval = P_copy_interval;
	     interval_comment = "";
	end;

	else if (P_copy_interval = -1) then do;		/* No timers in use */
	     static.interval = 0;
	     interval_comment = " (disabled)";
	end;

	else do;
	     static.interval = DEFAULT_COPY_INTERVAL;
	     if (P_page_threshold = 0) then
		interval_comment = " (default)";
	     else interval_comment = " (installation_parm value invalid)";
	end;

	call sys_log_ (SL_LOG_SILENT,
	     "^a: Syserr thresholds: ^d page^[s^]^a, ^d second^[s^]^a",
	     WHOAMI, static.threshold, (static.threshold ^= 1),
	     threshold_comment, static.interval, (static.interval ^= 1),
	     interval_comment);

	return;
     end set_threshold_values;
%page;

get_history_dir:
     procedure ();

declare  my_ring fixed bin (3);
declare  dir_type fixed bin (2);
declare  dir_mode bit (36) aligned;
declare  history_dname char (168);
declare  history_ename char (32);
declare  new_ename char (32);
declare  history_rings (3) fixed bin (3);

declare  1 history_acl (4) aligned like directory_acl_entry;
declare  1 history_inacl (4) aligned like segment_acl_entry;


	call expand_pathname_ (log_data_$syserr_log_history_dir,
	     history_dname, history_ename, (0));	/* Guaranteed to work */
	call cu_$level_get (my_ring);

	call hcs_$status_minf (history_dname, history_ename, 1, dir_type, (0), code);
	if (code = error_table_$noentry) then
	     goto CREATE_HISTORY_DIR;
	else if (code ^= 0) then
	     goto REPLACE_HISTORY_DIR;
	else if (dir_type ^= 2) then do;		/* DIRECTORY */
	     code = error_table_$notadir;
	     goto REPLACE_HISTORY_DIR;
	end;

	call hcs_$get_user_access_modes (history_dname, history_ename, "", my_ring, dir_mode, (""b), code);
	if (code ^= 0) then
	     goto REPLACE_HISTORY_DIR;
	else if (dir_mode ^= SMA_ACCESS) then do;
	     code = error_table_$no_m_permission;
	     goto REPLACE_HISTORY_DIR;
	end;

	else return;				/* All is OK: History dir exists, and we have SMA */


REPLACE_HISTORY_DIR:
	call sys_log_$error_log (SL_LOG, code, WHOAMI,
	     "Could not use old syserr history dir:^3x^a>^a",
	     history_dname, history_ename);

	new_ename = "syserr_log." || unique_chars_ (""b);
	call hcs_$chname_file (history_dname, history_ename, history_ename, new_ename, code);
	if (code = 0) then
	     call sys_log_ (SL_LOG, "^a: Renamed ^a>^a to ^a",
		WHOAMI, history_dname, history_ename, new_ename);
	else
	     call sys_log_$error_log (SL_LOG_BEEP, code, WHOAMI,
		"Cannot rename ^a>^a to ^a", history_dname, history_ename, new_ename);


CREATE_HISTORY_DIR:
	history_rings (*) = my_ring;
	unspec (history_acl) = ""b;
	history_acl (1).access_name = get_group_id_$tag_star ();
	history_acl (1).mode = SMA_ACCESS;
	history_acl (2).access_name = "*.SysDaemon.*";
	history_acl (2).mode = S_ACCESS;
	history_acl (3).access_name = "*.SysMaint.*";
	history_acl (3).mode = S_ACCESS;
	history_acl (4).access_name = "*.SysAdmin.*";
	history_acl (4).mode = S_ACCESS;

	unspec (history_inacl) = ""b;
	history_inacl (*).access_name = history_acl (*).access_name;
	history_inacl (*).mode = R_ACCESS;
	history_inacl (1).mode = RW_ACCESS;

	call hcs_$append_branchx (history_dname, history_ename,
	     SMA_ACCESS_BIN, history_rings, (get_group_id_$tag_star ()), 1, 0, 0, code);
	if (code ^= 0) then do;
	     call sys_log_$error_log (SL_LOG_BEEP, code, WHOAMI,
		"Could not create ^a>^a.^/Automatic syserr log copying not initialized.",
		history_dname, history_ename);
	     call as_dump_ (WHOAMI);
	     call stop_copying ("1"b);
	     goto INIT_ERROR_EXIT;
	end;

	else call sys_log_ (SL_LOG, "^a: Created ^a>^a", WHOAMI, history_dname, history_ename);

	call hcs_$replace_dir_acl (history_dname, history_ename,
	     addr (history_acl), dimension (history_acl, 1), "0"b, code);
	if (code ^= 0) then
	     call sys_log_$error_log (SL_LOG, code, WHOAMI,
		"Cannot replace ACL on ^a>^a", history_dname, history_ename);

	call hcs_$replace_inacl (history_dname, history_ename,
	     addr (history_inacl), dimension (history_inacl, 1), "0"b, my_ring, code);
	if (code ^= 0) then
	     call sys_log_$error_log (SL_LOG, code, WHOAMI,
		"Cannot replace initial ACL on ^a>^a", history_dname, history_ename);

	return;
     end get_history_dir;
%page;

verify_sequence:
     procedure ();

/* This procedure functions only once per bootload.  It ensures that
   the sequence numbers in the log partition (paged ring 0 log) are larger
   than those already in the history log segments.  (The sequence may have
   been reset to 1000000 due to a clearing of the partition). */

declare  new_sequence_start fixed bin (35);
declare  bit_count fixed bin (24);
declare  log_idx fixed bin;
declare  system_area_ptr pointer;
declare  system_area area based (system_area_ptr);

	if static.initialized then			/* one time only */
	     return;

	log_segment_ptr = null ();
	log_read_data_ptr = null ();
	call log_list_history_$single_dir (log_data_$syserr_log_history_dir, log_data_$syserr_log_name, log_read_data_ptr, code);

	if (code ^= 0) then do;
	     call sys_log_$error_log (SL_LOG_BEEP, code, WHOAMI, "Error obtaining syserr log history.");
	     call stop_copying ("1"b);
	     goto INIT_ERROR_EXIT;
	end;

	if (log_read_data_ptr = null ()) then
	     return;				/* no history, any sequence OK */
	if log_read_data.n_segments < 1 then
	     goto EXIT;

	do log_idx = 1 to log_read_data.n_segments;
	     call initiate_file_ (log_data_$syserr_log_history_dir, log_read_data.ename (log_idx), R_ACCESS, log_segment_ptr, bit_count, code);
	     if code = 0 then goto log_initiated;
	end;

/* drop through to here if we can't initiate any log segments */
	call sys_log_ (SL_LOG_BEEP, "^a: Unable to open syserr log in ^a.", WHOAMI, log_data_$syserr_log_history_dir);
	call stop_copying ("1"b);
	goto ERROR_RETURN;

/* arrive here when we find a log history initiated */
log_initiated:
	new_sequence_start = (log_idx * 100000) + log_segment.last_sequence;
						/* new starting point if we need to adjust sequence numbers */
						/* 100000 is number we'll allow per log segment */

	call hphcs_$new_syserr_verify_sequence (log_segment.last_sequence, new_sequence_start, code);
	if (code ^= 0) then do;
	     call sys_log_$error_log (SL_LOG_BEEP, code, WHOAMI, "Error verifying log partition sequence numbers.");
	     call stop_copying ("1"b);
	     goto ERROR_RETURN;
	end;

EXIT:
	system_area_ptr = get_system_free_area_ ();
	free log_read_data in (system_area);
	return;

ERROR_RETURN:
	system_area_ptr = get_system_free_area_ ();
	free log_read_data in (system_area);
	goto INIT_ERROR_EXIT;

     end verify_sequence;
%page;

syserr_log_man_$as_copy_log:
     entry ();

/* Entry point called either via a wakeup from ring 0 or a call from the Initializer process (as a command) */

	if ^static.initialized then			/* Out of sequence, Jack */
	     return;

	log_segment_ptr = null ();			/* Initialize for cleanup handler */
	log_write_data_ptr = null ();

	on condition (any_other)
	     call as_any_other_handler_ (WHOAMI,
		copy_error_cleanup, COPY_FINISHED, COPY_ERROR_EXIT);

	on condition (cleanup)
	     call copy_cleanup ();

	if static.disabled then do;			/* Make sure it's disabled */
	     call stop_copying ("0"b);
	     return;
	end;

	static.total_copies = static.total_copies + 1;

	copy_start.time = clock ();			/* Set up for metering */
	call cpu_time_and_paging_ (copy_start.pf, copy_start.vcpu, (0));

	call copy_syserr_once ();			/* If there's a leftover one waiting, copy it out */

	call hphcs_$new_syserr_info ((0), current_log_empty);

	if current_log_empty then
	     static.null_copies = static.null_copies + 1; /* Meter the event */

	else do;					/* If there's anything in the current log, */
	     call hphcs_$new_syserr_swap_logs (code);	/* swap it with the empty one, and copy */
	     if (code = 0) then
		call copy_syserr_once ();

	     else call sys_log_$error_log (SL_LOG, code, WHOAMI,
		     "Attempting to swap syserr log segments.");
	end;

	call ipc_$drain_chn (static.channel, (0));	/* Drain anything that's left */

	call arg_count_ (n_args);
	if (static.interval ^= 0) & (n_args = 1) then do; /* If timed, and got possible event_call_info, reschedule */
	     call cu_$arg_ptr (1, argp, argl, code);
	     if code ^= 0 then goto COPY_FINISHED;
	     begin;				/* new frame to establish new any_other handler */
		on any_other goto COPY_FINISHED;
		event_call_info_ptr = argp -> based_ptr;
		if addr (event_call_info.message) -> based_char8 = "alarm___"
		then do;
		     static.timed_copies = static.timed_copies + 1;
		     call timer_manager_$alarm_wakeup (static.interval, RELATIVE_SECONDS, static.channel);
		end;
	     end;					/* begin block */
	end;

COPY_FINISHED:
	call copy_cleanup ();

	copy_finish.time = clock ();			/* Collect final metering numbers */
	call cpu_time_and_paging_ (copy_finish.pf, copy_finish.vcpu, (0));
	static.meters = static.meters + (copy_finish - copy_start); /* And add them in */

	return;



COPY_ERROR_EXIT:
	call copy_error_cleanup ();
	return;
%page;

copy_syserr_once:
     procedure ();

declare  log_swap_time fixed bin (71);
declare  old_log_name char (32);
declare  segment_finished bit (1) aligned;


	call hphcs_$new_syserr_info (log_swap_time, ("0"b));
	if (log_swap_time = 0) then			/* Nothing for us to copy */
	     return;

	old_log_name = log_name_$name (log_data_$syserr_log_name, log_swap_time);

	call log_initiate_ (log_data_$syserr_log_dir, old_log_name, 10, log_segment_ptr, code);
	if (code ^= 0) then do;
	     call sys_log_$error_log (SL_LOG, code, WHOAMI,
		"Cannot initiate log ^a>^a", log_data_$syserr_log_dir, old_log_name);
	     call stop_copying ("1"b);
	     return;
	end;

	call log_write_$open_for_migrate
	     (log_data_$syserr_log_history_dir, log_data_$syserr_log_name,
	     "1"b, log_write_data_ptr, code);

	if (code ^= 0) then do;
	     call sys_log_$error_log (SL_LOG, code, WHOAMI,
		"Cannot open history log ^a>^a",
		log_data_$syserr_log_history_dir, log_data_$syserr_log_name);
	     call stop_copying ("1"b);
	     return;
	end;

	segment_finished = "0"b;
	log_message_ptr = null ();			/* Start at the first message */
	do while (^segment_finished);
	     call log_position_$next_message (log_segment_ptr, log_message_ptr, ("0"b));

	     if (log_message_ptr ^= null ()) then do;
		call route_syserr_message ();		/* For our friends in the recovery room */

		call log_move_$message (log_write_data_ptr,
		     log_message_ptr, (null ()), code);

		if (code ^= 0) then do;
		     call sys_log_$error_log (SL_LOG, code, WHOAMI,
			"Cannot migrate message #^d", log_message.sequence);
		     call stop_copying ("1"b);
		     return;
		end;

		static.total_messages = static.total_messages + 1;
	     end;

	     else segment_finished = "1"b;		/* Quit if no next message */
	end;

	call hphcs_$new_syserr_reuse_log (code);	/* Return the one we just copied */
	if (code ^= 0) then
	     call sys_log_$error_log (SL_LOG, code, WHOAMI,
		"Calling hphcs_$new_syserr_reuse_log.");

	return;
     end copy_syserr_once;
%page;

route_syserr_message:
     procedure ();

declare  data_code fixed bin;

/* This procedure is responsible for sending syserr messages out to another
   destination if console recovery is happening. It also handles special
   routing for messages sacred to the Answering Service, replacing the
   syserrlog_segdamage_scan_. */

/* Additionally, this guy could take care of all RCP messages, if only
   it knew how... */


	if (dimension (log_message.data, 1) = 0) then	/* No binary info */
	     goto NO_BINARY_DATA;

	if log_message.data_class = "syserr"
	then do;
	     data_code = binary (log_message.data (1), 36); /* See whether it's one we recognize */
	     if (data_code < 1) | (data_code >= SB_end_of_table) then
		goto NO_BINARY_DATA;

/* Check first for segment damage messages */

	     if (substr (syserr_binary_seg_damage_mask, data_code, 1)) then do;
		call sys_log_ (SL_LOG, "Syserr msg #^d: ^a",
		     log_message.sequence, log_message.text);
		call sys_log_ (SL_LOG, "^3xSegment: ^a",
		     binary_segmsg_util_ (addr (log_message.data (2))));
	     end;

/* Then check for volume damage messages */

	     else if (substr (syserr_binary_vol_damage_mask, data_code, 1)) then do;
		call sys_log_ (SL_LOG, "Syserr msg #^d: ^a",
		     log_message.sequence, log_message.text);
		call sys_log_ (SL_LOG, "^3xVolume: ^a",
		     binary_segmsg_util_$interpret_pvname (addr (log_message.data (2))));
	     end;

	     else goto NO_BINARY_DATA;

	end;

	else if log_message.data_class = SB_segdamage_data_class then do;
	     call sys_log_ (SL_LOG, "Syserr msg #^d: ^a",
		log_message.sequence, log_message.text);
	     call sys_log_ (SL_LOG, "^3xSegment: ^a",
		binary_segmsg_util_ (addr (log_message.data (1))));
	end;

	else if log_message.data_class = SB_voldamage_data_class then do;
	     call sys_log_ (SL_LOG, "Syserr msg #^d: ^a",
		log_message.sequence, log_message.text);
	     call sys_log_ (SL_LOG, "^3xVolume: ^a",
		binary_segmsg_util_$interpret_pvname (addr (log_message.data (1))));
	end;


NO_BINARY_DATA:
	if ^static_recovery_flag then			/* Not in recovery mode */
	     return;

	if (log_message.sequence < static_recovery_limit) then /* Not yet a message we care about */
	     return;

	if ^write_flags (mod (log_message.severity, 10)) then /* Not a printable message */
	     return;

	call mc_con_rec_$queue_log_message		/* If it passes all the tests, send it back */
	     (log_message_ptr, (alarm_flags (mod (log_message.severity, 10))));

	return;
     end route_syserr_message;
%page;

syserr_log_man_$print_meters:
     entry ();

	call ioa_ ("Syserr copy information:");
	call ioa_ ("^3xTotal copies:^31t^7d (^d null) (^d timed)",
	     static.total_copies, static.null_copies, static.timed_copies);
	call ioa_ ("^3xMessages copied:^31t^7d", static.total_messages);
	call ioa_ ("^3xCopy channel:^31t^24.3b", unspec (static.channel));
	call ioa_ ("^3xCopying is:^31t^[dis^;en^]abled", static.disabled);
	call ioa_ ("^3xCopy interval:^31t^[^7d seconds^;[disabled]^]",
	     (static.interval ^= 0), static.interval);
	call ioa_ ("^3xCopy threshold:^31t^[^7d pages^;[disabled]^]",
	     (static.threshold ^= 0), static.threshold);

	call ioa_ ("^3xSyserr recovery is:^31t^[dis^;en^]abled",
	     static_recovery_flag);

	call ioa_ ("^/Syserr copying meters:");
	call ioa_ ("^24t	 Real time     VCPU time   Page faults");

	call ioa_ ("^3xTotal:^24t^14.4f^14.4f^14.4f",
	     seconds_per (static.meters.time, 1),
	     seconds_per (static.meters.vcpu, 1),
	     instances_per (static.meters.pf, 1));
	call ioa_ ("^3xAve/copy:^24t^14.4f^14.4f^14.4f",
	     seconds_per (static.meters.time, static.total_copies),
	     seconds_per (static.meters.vcpu, static.total_copies),
	     instances_per (static.meters.pf, static.total_copies));
	call ioa_ ("^3xAve/message:^24t^14.4f^14.4f^14.4f",
	     seconds_per (static.meters.time, static.total_messages),
	     seconds_per (static.meters.vcpu, static.total_messages),
	     instances_per (static.meters.pf, static.total_messages));
	call ioa_ ("");

	return;



seconds_per:
     procedure (P_time, P_count) returns (float bin);

declare  P_time fixed bin (71) parameter;
declare  P_instances fixed bin (35) parameter;
declare  P_count fixed bin (35) parameter;

	if (P_count = 0) then
	     return (0.0e0);
	else return (float (P_time) / (1.0e6 * float (P_count)));


instances_per:
     entry (P_instances, P_count) returns (float bin);

	if (P_count = 0) then
	     return (0.0e0);
	else return (float (P_instances) / float (P_count));

     end seconds_per;
%page;

copy_error_cleanup:
     procedure ();

	call stop_copying ("1"b);

	call copy_cleanup ();

	return;
     end copy_error_cleanup;



copy_cleanup:
     procedure ();

	if (log_segment_ptr ^= null ()) then
	     call hcs_$terminate_noname (log_segment_ptr, (0));
	log_segment_ptr = null ();

	if (log_write_data_ptr ^= null ()) then
	     call log_write_$close (log_write_data_ptr, (0));
	log_write_data_ptr = null ();

	return;
     end copy_cleanup;
%page;

/* Internal procedure to disable log copying should it be necessary */

stop_copying:
     procedure (give_message);

declare  give_message bit (1) parameter;		/* If ON, Put message in sys_log_ */


	if give_message then
	     call sys_log_$error_log (SL_LOG, 0, WHOAMI,
		"Automatic syserr log copying disabled.");

	call hphcs_$new_syserr_copy_init (0, 0);

	if (static.interval ^= 0) then
	     call timer_manager_$reset_alarm_wakeup (static.channel);

	call ipc_$delete_ev_chn (static.channel, (0));

	static.channel = 0;
	static.interval = 0;
	static.threshold = 0;
	static.disabled = "1"b;			/* Mark it as turned off */

	return;
     end stop_copying;

/* format: off */

%page; %include access_mode_values;
%page; %include acl_structures;
%page; %include sys_log_constants;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_wakeup_priorities;
%page; %include sc_stat_;
%page; %include syserr_actions;
%page; %include syserr_binary_def;
%page; %include log_segment;
%page; %include log_message;
%page; %include log_read_data;
%page; %include event_call_info;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   Syserr msg #NNNNN: MESSAGE-TEXT
   .br
   Segment: PATHNAME
   .br
   Volume: VOLUME-NAME

   S:     as (severity0)

   T:     $run

   M:     This message is a repetition of a syserr log message which reported
   damage to a segment or a physical volume.  There will always be two
   such messages in sequence, a "Syserr msg. #XXX" message and either
   a "Volume:" or "Segment:" message. The first message is a copy of the
   logged syserr message of the given number;  the second message identifies
   the volume or segment mentioned.  This allows segments damaged by system
   action, or segments in which the physical volume salvager observed damage,
   to be identified unambiguously.  These messages are logged in the Answering
   Service log at answering service startup time and every accounting update.

   A:     Correlate volume salvager messages with previous printed volume
   salvager output to obtain more information about segment damage detected
   by the volume salvager. For those segments which are mentioned, which have
   not been deleted, or are not in deleted directories (the "Segment:" message 
   says if this is the case) contact persons  responsible for the ownership
   of that segment, and undertake recovery procedures if needed.


   Message:
   syserr_log_man_: Called too early.

   S:     as (severity2)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Could not create event channel.  Automatic syserr
   log copying not initialized.  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Automatic syserr log copying disabled.

   S:     as (severity1)

   T:     $run

   M:     Automatic copying of syserr messages into >sc1>syserr_log has
   been stopped, due to an error in the copying process. Another message will
   have been printed prior to this one, describing the problem.
   An Answering Service dump usually will have been created, as well.

   A:     If the error is recoverable (temporary disk error, record quota
   overflow, etc.-- see the previous message(s) to make that decision), syserr
   copying can be restarted by issuing the following command in admin mode
   (ur using send_admin_command):
.in +5

syserr_log_man_$restart_copying
.in -5

   If the problem persists, delete the first segment (first in the list
   produced by the list command) in >sc1>syserr_log, and restart copying.
   If the problem still persists, rename or delete >sc1>syserr_log and
   reboot; the directory will be re-created automatically.

   The display_log_segment command can be used to examine individual log
   segments for damage.


   Message:
   syserr_log_man_: Syserr thresholds: NNN pages (COMMENT), NNN seconds (COMMENT)

   S:     as (severity0)

   T:     $init

   M:     These are the thresholds for when Answering Service syserr copying
   will be performed.  Each value may be followed by a comment; the comment 
   "(default)" indicates that the installation_parms value was zero, indicating
   that a default value is used. The comment "(disabled)" indicates that the 
   installation_parms value was set to disable this log copying mechanism. 
   The comment "(installation_parms value invalid)" means just that; the value
   in installation_parms must be updated, and meantime, a default is applied.

   A:     $note


   Message:
   syserr_log_man_: Bad syserr_copy_interval value NNN seconds, using 3600 seconds instead.

   S:     as (severity1)

   T:     $init

   M:     The syserr copy interval in installation_parms is invalid.

   A:     Use ed_installation_parms to correct it. A default will be used
   until then.


   Message:
   syserr_log_man_: Could not use old syserr history dir:  >sc1>syserr_log  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     The syserr log history directory (>sc1>syserr_log) cannot be used;
   the reason is indicated by the error message. The system will attempt to
   rename it and create a new one; any existing log segments may be moved
   from the old directory into the new (current) one once the system comes
   up if the renaming is successful.

   A:     $notify
   The condition causing the error should be corrected, and the system re-booted.


   Message:
   syserr_log_man_: Renamed >sc1>syserr_log to NEW-NAME

   S:     as (severity1)

   T:     $init

   M:     Indicates that the history directory has been renamed after an error
   in attempting to use it. Old log segments can be moved from here back into
   >sc1>syserr_log.

   A:     $notify


   Message:
   syserr_log_man_: Cannot rename PATHNAME to NEW-NAME. ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Created >sc1>syserr_log

   S:     as (severity0)

   T:     $init

   M:     The syserr history directory, >sc1>syserr_log, was created
   automatically when it was found missing during initialization. This
   is normal during a cold boot, but an error at all other times, since
   it indicates that the directory was missing.

   A:     $notify


   Message:
   syserr_log_man_: Could not create >sc1>syserr_log. Automatic syserr
   log copying not initialized. ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     The syserr history directory was found to be missing during initialization,
   and a new one could not be created; this probably indicates file system damage.

   A:     $notify


   Message:
   syserr_log_man_: Cannot replace ACL on >sc1>syserr_log. ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Cannot replace initial ACL on >sc1>syserr_log.  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Attempting to swap syserr log segments.  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Cannot initiate log LOG-PATHNAME.  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Cannot open history log LOG-PATHNAME.  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message: syserr_log_man_: Cannot migrate message #NNNNNNN

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Calling hphcs_$new_syserr_reuse_log  ERROR MESSAGE

   S:     as (severity1)

   T:     $init

   M:     $err

   A:     $notify


   Message:
   syserr_log_man_: Error obtaining syserr log history.  MESSAGE

   S:	as (severity2)

   T:	$init

   M:	To verify syserr message sequence numbers will continue to increase
   despite clearing of the log partition, the AS must look at the
   existing log segments.  However, some inconsistancy in the first
   history directory prevented this. (>sc1>syserr_log).

   A:	Fix any problems and issue the command "syserr_log_man_$restart_copying"
   from admin mode in the initializer process.


   Message:
   syserr_log_man_: Unable to open syserr log in PATH.

   S:	as (severity2)

   T:	$init

   M:	To verify syserr message sequence numbers will continue to increase
   despite clearing of the log partition, the AS must look at the
   existing log segments.  However, some inconsistancy in the first
   history directory prevented this. (>sc1>syserr_log).

   A:	$notify
   Fix any problems in the syserr log history dir and issue the
   command "syserr_log_man_$restart_copying" from admin mode in the
   initializer process.


   Message:
   syserr_log_man_: Error verifying log partition sequence numbers.

   S:	as (severity2)

   T:	$init

   M:	$err
   There is some error in the log partition which prevents adjustment of
   the sequence numbers.

   A:	$notify

   END MESSAGE DOCUMENTATION
   */

     end syserr_log_man_;




		    operator_com_channel_cmds_.pl1  10/10/88  1513.4rew 10/07/88  1232.4       72198



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-12-05,MSharpe), approve(87-05-01,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Original coding.  Moved the com_channel related commands out of admin_.
  2) change(87-04-26,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
  3) change(88-09-08,Parisek), approve(88-09-28,MCR7996),
     audit(88-10-05,Hunter), install(88-10-07,MR12.2-1140):
     Removed references to sys_log_$command_error_log entry which does not
     exist and changed them to sys_log_$command_error which does exist.
                                                   END HISTORY COMMENTS */
/* format: style4,indattr */

operator_com_channel_cmds_: procedure ();

/* The following two entry points provide commands to change the state of
   a tty channel, attach, and remove.  Other commands which manipulate the
   process using the channel, ie., detach, terminate, bump, unbump, and
   disconnect may be found in in admin_process_commands_.

*/


%page;

/*  AUTOMATIC */

dcl  action	        char (8) aligned;
dcl  action_flag	        bit (1) aligned;
dcl  action_log	        char (12) aligned;
dcl  answer	        char (256) init ("");
dcl  arg_index	        fixed bin (17);
dcl  arg_length	        fixed bin (21);
dcl  arg_list_ptr	        ptr;
dcl  arg_ptr	        ptr;
dcl  code		        fixed bin (35);
dcl  comname	        char (12) aligned;
dcl  input_channel	        char (32);			/* channel id to look for */

/* BASED */

dcl  arg		        char (arg_length) based (arg_ptr);

/* BUILTIN */

dcl  (addr, null)	        builtin;


/* ENTRY */

dcl  asu_$asu_attach        entry (char (*), fixed bin (35));
dcl  asu_$asu_remove        entry (ptr);
dcl  cu_$arg_list_ptr       entry () returns (ptr);
dcl  cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21),
		        fixed bin (35), ptr);
dcl  sys_log_$command       entry options (variable);
dcl  sys_log_$command_error entry options (variable);

/* EXTERNAL */

dcl  error_table_$action_not_performed fixed bin (35) ext static;

%page;
attach:
     entry options (variable);

/**** This is the operator "attach" command.  It allows the operator to
      attach a communications channel to the answering service. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "attach";
	action = "attach  ";
	action_log = "attached";
	action_flag = "0"b;
	do arg_index = 1 to 25;			/* take up to 25 args */
	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length,
		code, arg_list_ptr);		/* get one argument, channel id */
	     if code ^= 0
	     then go to ATTACH_RETURN;

	     input_channel = arg;			/* save channel id */

	     call asu_$asu_attach (input_channel, code);	/* add channel to answer table */
	     if code = 0 then do;			/* if no error */
		call sys_log_$command (-1, "attach: ^a attached.",
		     input_channel);
		action_flag = "1"b;			/* one worked. */
	     end;
	     else do;				/* some error occurred. */
		if code ^= error_table_$action_not_performed
						/* if asu_attach did not say what */
		then call sys_log_$command_error (1, code,
			comname, input_channel);
						/* we will do so */
	     end;
	end;

ATTACH_RETURN:

	if ^action_flag				/* complain if none worked. */
	then call sys_log_$command (-1, "attach: error: not done");

	return;

%page;
remove:
     entry options (variable);

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "remove";
	action = "remove  ";			/* set action code */
	action_log = "removed";
	action_flag = "0"b;				/* none done yet */
	do arg_index = 1 to 25;			/* take up to 25 args */
	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length,
		code, arg_list_ptr);		/* get one argument, channel id */
	     if code ^= 0
	     then go to REMOVE_RETURN;

	     input_channel = arg;			/* save channel id */
	     cdtep = FIND_CDTE (input_channel);
	     if cdtep = null ()
	     then call sys_log_$command (-1, "remove: Channel ^a not found.",
		     input_channel);
	     else do;
		if cdte.current_service_type = MC_SERVICE
		then call sys_log_$command (1,
			"remove: Channel ^a is in use by the message coordinator and can not be removed",
			cdte.name);
		else do;
		     call asu_$asu_remove (cdtep);	/* remove it */
		     action_flag = "1"b;		/* one worked */
		     call sys_log_$command (-1, "remove: ^a removed",
			input_channel);
		end;
	     end;
	end;

REMOVE_RETURN:
	if ^action_flag				/* complain if none worked. */
	then call sys_log_$command (-1, "remove: error: not done");

	return;

%page;

FIND_CDTE:
     procedure (P_channel_name) returns (ptr);

dcl  P_channel_name	        char (*) parameter;
dcl  cdtep	        ptr automatic;
dcl  i		        fixed bin (17) automatic;

	do i = 1 to scdtp -> cdt.current_size;
	     cdtep = addr (scdtp -> cdt.cdt_entry (i));
	     if cdtep -> cdte.in_use > NOW_FREE
	     then if cdtep -> cdte.name = P_channel_name
		then return (cdtep);
	end;

	return (null ());

     end FIND_CDTE;

%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dialup_values;
%page; %include sc_stat_;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   attach: bad arg "AAAA"

   S:	as (severity1).

   T:	$response

   M:	A bad argument was furnished with an attach
   command.  The argument is skipped.

   A:	Enter a corrected command.


   Message:
   remove: bad arg "AAAA"

   S:	as (severity1).

   T:	$response

   M:	A bad argument was furnished with an remove
   command.  The argument is skipped.

   A:	Enter a corrected command.


   Message:
   attach: error: not done

   S:	as (severity1).

   T:	$response

   M:	Bad arguments were given to an attach
   command.  No action resulted.

   A:	$tryagain


   Message:
   remove: error: not done

   S:	as (severity1).

   T:	$response

   M:	Bad arguments were given to an remove
   command.  No action resulted.

   A:	$tryagain


   Message:
   remove: ttyXXX is in use by the message coordinator and can not be removed.

   S:	as (severity1).

   T:	$response

   M:	An operator remove command specified a message coordinator channel.
   The channel was not removed.

   A:	Enter a corrected command line.  Use the drop command to
   take a channel away from the message coordinator.


   Message:
   attach: TTYxxx attached

   S:	as (severity1).

   T:	In response to an operator attach command.

   M:	This is the response to an attach TTYxxx command.  The
   device channel is now connected to the Answering Service and ready for
   dialups.

   A:	$ignore


   Message:
   attach: Action not performed. ttyXXX

   S:	as (severity1).

   T:	In response to an operator attach command.

   M:	This is the response to attach TTYxxx if no more room is
   available in the answer table for channel entries.  The line is not
   attached.

   A:	$contact


   Message:
   remove: ttyXXX removed

   S:	as (severity1).

   T:	In response to an operator remove command.

   M:	This response to the operator command remove TTYxxx
   indicates the channel is no longer available for dialups.  If a user
   was on the channel, he is bumped with no message but "hangup".
   Note that if a user calls in on this channel, and the modem answers,
   the user gets a carriage return, but no welcoming message from the system,
   and he cannot log in.

   A:	Remember to busy out the modem so that no user can call
   the channel.


   END MESSAGE DOCUMENTATION */


     end operator_com_channel_cmds_;




		    operator_mc_cmds_.pl1           07/20/88  1251.6r w 07/19/88  1536.5      451692



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-01-07,MSharpe), approve(87-07-09,MCR7690),
     audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055):
     Removed the message_coordinator commands from admin_ and created this
     program.  Added accept_vchn which accepts virtual channel names.  Fixed
     accept to leave broadcast list alone if not specified.
  2) change(87-04-07,Parisek), approve(87-07-09,MCR7690),
     audit(87-08-03,Beattie), install(87-08-04,MR12.1-1055):
     Bypass printing error message on MC terminal if code returned by
     mc_commands_$new_tty is error_table_$ioname_not_active. We don't care if
     it's not active cause if not it will become active after "accept".
  3) change(87-04-26,GDixon), approve(87-07-09,MCR7690),
     audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
  4) change(87-06-25,Parisek), approve(87-06-25,MCR7690),
     audit(87-08-03,Beattie), install(87-08-04,MR12.1-1055):
     Created a new internal procedure for searching the answer table for DSA MC
     user (no proc), and send a "bump" wakeup to AS to remove the ute for the
     user only when "drop" or "substty" is called.
  5) change(87-06-29,Parisek), approve(87-06-29,MCR7690),
     audit(87-08-03,Beattie), install(87-08-04,MR12.1-1055):
     Ignore error_table_$action_not_performed returned from asu_$bump_user if
     dsa channel.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

%page;
operator_mc_cmds_:
     proc ();

/* AUTOMATIC */

dcl  answer	        char (256) init ("");
dcl  arg_count	        fixed bin (17);
dcl  arg_index	        fixed bin (17);
dcl  arg_length	        fixed bin (21);
dcl  arg_list_ptr	        ptr;
dcl  arg_ptr	        ptr;
dcl  attauth	        bit (36);			/*  .. privilege bits */
dcl  attchan	        char (32);			/* .. channel ID or file name */
dcl  attchan1	        char (32);			/* .. channel ID or file name */
dcl  attype	        char (8);			/* .. attachment type (file or tty) */
dcl  auth_flag	        bit (1) aligned;
dcl  bc_flag	        bit (1) aligned;
dcl  bc_list	        char (329) aligned;		/* 10 char (32) + 9 separating commas */
dcl  cdte_flag	        bit (1) aligned;		/* 1=>attchan is defined in cdt */
dcl  code		        fixed bin (35);
dcl  comname	        char (32) aligned;
dcl  dsa_flag	        bit (1) aligned;		/* dsa channel specified */
dcl  iutep                  ptr;			/* Initializer's utep */
dcl  reply_target	        char (32);
dcl  source	        char (8);			/* Source name, used in "route" */
dcl  stream	        char (32);			/* .. stream name */
dcl  target_flag	        bit (1) aligned;
dcl  vcon		        char (32);			/* .. virtual console name */
dcl  vcon1	        char (32);			/* .. virtual console name */
dcl  virtual_dsa            bit (1) aligned;		/* virtual dsa channel ident */

dcl 1 CAI structure aligned like channel_audit_info automatic;

/* CONSTANTS */

declare  (TRUE init ("1"b),
	FALSE init (""b)) bit (1) aligned int static options (constant);

/* BASED */

dcl  arg		        char (arg_length) based (arg_ptr);

/* BUILTIN */

dcl  (addr, index, length, null, rtrim, substr)   builtin;

/* ENTRY */

dcl  as_access_audit_$channel
                            entry (ptr, ptr, ptr, fixed bin, ptr, char(*));
dcl  asu_$bump_user         entry (ptr, char (*), fixed bin (35), fixed bin);
dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$arg_count_rel      entry (fixed bin, ptr, fixed bin (35));
dcl  cv_oct_check_	        entry (char (*), fixed bin (35)) returns (bit (36));
dcl  get_process_access_class_
                            entry () returns (bit (72) aligned);
dcl  get_process_id_        entry () returns (bit (36));
dcl  hcs_$initiate	        entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  initiate_file_         entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_$rsnnl	        entry options (variable);
dcl  mc_commands_$new_tty   entry (char (*), bit (36), bit (1) aligned,
			ptr, fixed bin (35));
dcl  mc_commands_$new_vchannel
		        entry (char (*), bit (36), ptr, fixed bin (35));
dcl  mc_commands_$set_restrict
		        entry (char (*), char (*), fixed bin (35));
dcl  mc_commands_$set_broadcast
		        entry (char (*), char (*), fixed bin (35));
dcl  mc_commands_$remove_tty
		        entry (char (*), bit (1) aligned, fixed bin (35));
dcl  mc_commands_$define    entry (char (*), char (*), char (*), fixed bin (35));
dcl  mc_commands_$deroute   entry (char (*), char (*), char (*), fixed bin (35));
dcl  mc_commands_$route     entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  mc_commands_$reroute   entry (char (*), char (*), char (*), char (*), char (*), fixed bin (35));
dcl  mc_commands_$undefine  entry (char (*), char (*), fixed bin (35));
dcl  mc_commands_$redefine  entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  mc_commands_$substty   entry (char (*), char (*), bit (1) aligned, ptr,
			 bit (1) aligned, fixed bin (35));
dcl  sys_log_$command       entry options (variable);
dcl  sys_log_$command_error entry options (variable);
dcl  terminate_file_        entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* EXTERNAL */

dcl  error_table_$action_not_performed 
                            fixed bin(35) ext static; 
dcl  error_table_$bad_arg   fixed bin (35) ext;
dcl  error_table_$bad_channel
		        fixed bin (35) ext;
dcl  error_table_$badopt    fixed bin (35) ext;
dcl  error_table_$ioname_not_active
                            fixed bin (35) ext;
dcl  error_table_$ioname_not_found
		        fixed bin (35) ext;
dcl  error_table_$ionmat    fixed bin (35) ext;
dcl  error_table_$noentry   fixed bin (35) ext; 
%page;

/* The following ten entries are used to invoke service functions of
   the answering service message coordinator program, which distributes
   messages from sources within the answering service and sources in
   daemon processes attached via "mrd_", to virtual consoles which in
   turn are connected either to real channels or to logs.
*/
accept:
     entry options (variable);

/**** The operator "accept" command.  It adds a new terminal to the
      message coordinator. */

          dutp = as_data_$dutp;	
          iutep = addr (dutbl.entry (1));		/* Initializer's utep for audit */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: accept";				/* Set up command name for err msg */

	call validate;				/* locate answer table */
	answer = "Usage: accept channel_id {authority} {target} {broadcast_list}";
	arg_index = 1;
	call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code,
	     arg_list_ptr);				/* arg 1 is tty id */
	if code ^= 0
	then go to ERROR_RETURN;			/* required */

	attchan = arg;

	if attchan = "otw_"
	then do;
	     answer = "This name is reserved for the system console.";
	     code = error_table_$bad_channel;
	     goto ERROR_RETURN;
	end;

	else if index (attchan, ".") ^= 0
	     then do;
		cdtep = null ();			/* may not be a terminal */
		if index (attchan, "dsa.") = 1	/* not in cdte; this test should be modified when other
						   formats of channel names become acceptable */

		then cdte_flag = ""b;
		else do;
		     cdte_flag = "1"b;
		     call check_acceptable (code);	/* make sure not used by answering service */

		     if code ^= 0
		     then go to ANSWER_RETURN;	/* error message will have been set up */
		end;

		if cdtep ^= null ()			/* if an MCS channel ... */
		then cdte.current_service_type = MC_SERVICE;
						/* flag as MC channel */
	     end;

	arg_index = arg_index + 1;
	auth_flag = "1"b;				/* assume authority is supplied */
	call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code,
	     arg_list_ptr);
	if code ^= 0
	then do;
	     auth_flag = ""b;			/* authority not supplied */
	     attauth = (36)"1"b;			/* second arg, if supplied, is privilege level */
	end;
	else if arg = "full"
	then attauth = (36)"1"b;			/* full is the current default */
	else if arg = "none"
	then attauth = (36)"0"b;			/* output-only terminals are ok */
	else if arg = "reply"
	then do;					/* as are reply-only */
	     attauth = "0"b;
	     addr (attauth) -> rcodebits.reply = "1"b;
						/* system_control_ checks these bits when command issured */
	end;
	else if arg = "daemon"
	then do;					/* also daemon-control */
	     attauth = "0"b;
	     addr (attauth) -> rcodebits.reply = "1"b;
	     addr (attauth) -> rcodebits.intercom = "1"b;
	     addr (attauth) -> rcodebits.exec = "1"b;
	end;
	else if arg = "query"
	then do;					/* almost zero privilege */
	     attauth = "0"b;
	     addr (attauth) -> rcodebits.status = "1"b;
	end;
	else do;					/* Assume octal. */
	     attauth = cv_oct_check_ (arg, code);
	     if code ^= 0
	     then do;
		answer = "unknown privilege code";
		go to ANSWER_RETURN;
	     end;
	end;

	answer = "Failed to accept " || attchan || ".";	/* prepare error message */
	call mc_commands_$new_tty (attchan, attauth, cdte_flag, arg_ptr,
	      code);				/* grab the new tty and set it up;
						   arg_ptr is actually superfluous here; turn_on_mc_
						   uses the value returned for the system console */

	if code = error_table_$ionmat
	then do;
	     call cu_$arg_count_rel (arg_count, arg_list_ptr, (0));
	     if arg_count = arg_index
	     then do;
		if ^auth_flag
		then				/* no new value supplied */
		     call sys_log_$command (SL_LOG, "operator_mc_cmds_: accept: ^a set to ""full"".", attchan);
		go to RETURN;
	     end;
	     code = 0;				/* go ahead and reset other attributes */
	end;

	if code = error_table_$ioname_not_active then;	/* Suppress error message on MC terminal */
	else if code ^= 0 then do;
	     if code = error_table_$ioname_not_found
	     then answer = "Channel " || attchan || "is not in Message Coordinator service.";
	     go to ERROR_RETURN;
	end;

	arg_index = arg_index + 1;
	call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code,
	     arg_list_ptr);				/* Next argument may be reply restricter. */
	if code ^= 0
	then do;
	     call AUDIT_OK ();
	     goto RETURN;				/* leave the rest alone */
	end;
	if arg ^= "*"
	then do;
	     answer = "Failed to set restriction to " || arg || ".";
	     call mc_commands_$set_restrict (attchan, arg, code);
	     if code ^= 0
	     then go to ERROR_RETURN;
	end;
	else do;
	     answer = "Failed to reset restriction.";
	     call mc_commands_$set_restrict (attchan, "", code);
	     if code ^= 0
	     then go to ERROR_RETURN;
	end;

	arg_index = arg_index + 1;
	call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code,
	     arg_list_ptr);				/* Next argument maybe broadcast list. */
	if code = 0
	then do;					/* optional. */
	     answer = "Failed to set broadcast list to " || arg || ".";
	     call mc_commands_$set_broadcast (attchan, arg, code);
	     if code ^= 0
	     then go to ERROR_RETURN;
	end;

	call AUDIT_OK ();
	go to RETURN;

%page;
accept_vchn:
     entry options (variable);

/**** The operator "accept_vchn" command.  It adds a new virtual channel
      to the message coordinator.  Virtual channels thus defined must be
      manually accepted by an operator when a user attempts to use them.*/

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: accept_vchn";			/* Set up command name for err msg */

	call validate;				/* locate answer table */
	answer = "Usage: accept_vchn channel_id -auth authority -target reply_target -bc_list input_broadcast_list";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* arg 1 is tty id */
	if code ^= 0
	then go to ERROR_RETURN;			/* required */

	attchan = arg;				/* copy arg */

	if index (attchan, ".") ^= 0
	then do;
	     answer = rtrim (attchan) ||
		".  Virtual channel names may not contain a "".""";
	     code = error_table_$bad_channel;
	     goto ERROR_RETURN;
	end;

	else if attchan = "otw_"
	     then do;
		answer = "This name is reserved for the system console.";
		code = error_table_$bad_channel;
		goto ERROR_RETURN;
	     end;

	auth_flag, target_flag, bc_flag = ""b;
	reply_target, bc_list = "";

	arg_index = 2;
	do while (arg_index <= arg_count);
	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code, arg_list_ptr);
	     arg_index = arg_index + 1;

	     if arg = "-auth" | arg = "-authority"
	     then do;
		auth_flag = "1"b;			/* necessary arg */

		call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code, arg_list_ptr);
		if code ^= 0
		then goto ERROR_RETURN;

		arg_index = arg_index + 1;

		if arg = "full"
		then attauth = (36)"1"b;		/* full is the current default */
		else if arg = "none"
		then attauth = (36)"0"b;		/* output-only terminals are ok */
		else if arg = "reply"
		then do;				/* as are reply-only */
		     attauth = "0"b;
		     addr (attauth) -> rcodebits.reply = "1"b;
						/* system_control_ checks these bits when command issued */
		end;

		else if arg = "daemon"
		then do;				/* also daemon-control */
		     attauth = "0"b;
		     addr (attauth) -> rcodebits.reply = "1"b;
		     addr (attauth) -> rcodebits.intercom = "1"b;
		     addr (attauth) -> rcodebits.exec = "1"b;
		end;

		else if arg = "query"
		then do;				/* almost zero privilege */
		     attauth = "0"b;
		     addr (attauth) -> rcodebits.status = "1"b;
		end;

		else do;				/* bad arg */
		     code = error_table_$bad_arg;
		     answer =
			"-auth may be followed by one of the following:^/ full, none, reply, daemon, query"
			;

		     go to ERROR_RETURN;
		end;
	     end;

	     else if arg = "-target"
	     then do;
		call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code, arg_list_ptr);
		if code ^= 0
		then goto ERROR_RETURN;

		target_flag = "1"b;
		arg_index = arg_index + 1;

		if arg_length > length (reply_target)
		then do;
		     code = error_table_$bad_arg;
		     answer = "Bad reply target: " || arg;
		     goto ERROR_RETURN;
		end;

		reply_target = arg;
	     end;

	     else if arg = "-bc_list" | arg = "-bcl"
	     then do;
		call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code, arg_list_ptr);
		if code ^= 0
		then goto ERROR_RETURN;

		bc_flag = "1"b;
		arg_index = arg_index + 1;
		if arg_length > length (bc_list)
		then do;
		     code = error_table_$bad_arg;
		     answer = "Bad broadcast list: " || arg;
		     goto ERROR_RETURN;
		end;
		bc_list = arg;
	     end;
	     else do;
		code = error_table_$badopt;
		answer = "Argument not accepted: " || arg;
		goto ERROR_RETURN;
	     end;
	end;

	if ^auth_flag
	then attauth = (36)"1"b;

	answer = "Failed to accept " || attchan || ".";

	call mc_commands_$new_vchannel (attchan, attauth, arg_ptr, code);
						/* set up a new virtual channel */

	if code = error_table_$ionmat
	then do;
	     if ^auth_flag				/* no new value supplied */
						/* so report that we assumed default */
	     then call sys_log_$command (SL_LOG, "operator_mc_cmds_: accept_vchn: ^a set to ""full"".", attchan);
	     if ^bc_flag & ^target_flag		/* user specified nothing else to do; */
	     then goto RETURN;

	     code = 0;				/* go ahead and reset other attributes */
	end;


	if code ^= 0
	then go to ERROR_RETURN;

	if target_flag
	then do;

	     if reply_target ^= "*"
	     then do;
		answer = "Failed to set restriction to " || reply_target
		     || ".";
		call mc_commands_$set_restrict (attchan, reply_target,
		     code);
		if code ^= 0
		then go to ERROR_RETURN;
	     end;
	     else do;
		answer = "Failed to reset restriction.";
		call mc_commands_$set_restrict (attchan, "", code);
		if code ^= 0
		then go to ERROR_RETURN;
	     end;
	end;

	if bc_flag
	then do;
	     answer = "Failed to set broadcast list to " || rtrim(bc_list) || ".";
	     call mc_commands_$set_broadcast (attchan, (rtrim (bc_list)),
		code);
	     if code ^= 0
	     then go to ERROR_RETURN;
	end;

	go to RETURN;

%page;
/* Make entry in Message Routing Table */

route:
     entry options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: route";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* Get first argument, source id */
	if code ^= 0
	then go to ERROR_RETURN;
	source = arg;				/* Copy source id */
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
	if code ^= 0
	then go to ERROR_RETURN;
	stream = arg;				/* Copy stream id */
	call cu_$arg_ptr_rel (3, arg_ptr, arg_length, code, arg_list_ptr);
						/* get vcon */
	if code ^= 0
	then go to ERROR_RETURN;
	if substr (arg, 1, 1) = "*"
	then do;					/* Want to ring the bell? */
	     attype = "alarm";			/* yes. */
	     vcon = substr (arg, 2);
	end;
	else do;
	     attype = "";
	     vcon = arg;
	end;
	answer = "route unsuccessful.";
	call mc_commands_$route (source, stream, vcon, attype, code);
	if code ^= 0
	then go to ERROR_RETURN;
	go to RETURN;

/* Define virtual console */

define:
     entry options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: define";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* first arg is vcon id */
	if code ^= 0
	then go to ERROR_RETURN;
	vcon = arg;
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
						/* get attachment type */
	if code ^= 0
	then go to ERROR_RETURN;
	attype = arg;
	call cu_$arg_ptr_rel (3, arg_ptr, arg_length, code, arg_list_ptr);
						/* get channel id */
	if code ^= 0
	then go to ERROR_RETURN;
	attchan = arg;
	answer = "define unsuccessful.";
	call mc_commands_$define (vcon, attype, attchan, code);
	if code ^= 0
	then go to ERROR_RETURN;
	go to RETURN;

/* Redefine destination for virtual console */

redefine:
     entry options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: redefine";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get vocn */
	if code ^= 0
	then go to ERROR_RETURN;
	vcon = arg;
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
						/* get dest */
	if code ^= 0
	then go to ERROR_RETURN;
	attchan = arg;
	call cu_$arg_ptr_rel (3, arg_ptr, arg_length, code, arg_list_ptr);
	if code ^= 0
	then go to ERROR_RETURN;
	attype = arg;
	call cu_$arg_ptr_rel (4, arg_ptr, arg_length, code, arg_list_ptr);
	if code ^= 0
	then go to ERROR_RETURN;
	attchan1 = arg;
	answer = "redefine unsuccessful.";
	call mc_commands_$redefine (vcon, attchan, attype, attchan1, code);
	if code ^= 0
	then go to ERROR_RETURN;
	go to RETURN;

/* Undefine channel from virtual console. (formerly deldest) */

undefine:
     entry options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: undefine";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get vcon */
	if code ^= 0
	then go to ERROR_RETURN;
	vcon = arg;
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
						/* get dest */
	if code ^= 0
	then go to ERROR_RETURN;
	attchan = arg;
	answer = "undefine unsuccessful.";
	call mc_commands_$undefine (vcon, attchan, code);
	if code ^= 0
	then go to ERROR_RETURN;
	go to RETURN;

/* Swap one destination (terminal or file) for another */

substty:
     entry options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: substty";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get channel */
	if code ^= 0
	then go to ERROR_RETURN;
	attchan1 = arg;

	virtual_dsa = ""b;
	if (index (attchan1, "dsa.") = 1) | (index (attchan1, ".") = 0) then do;
	     dsa_flag = "1"b;
	     if index (attchan1, ".") = 0 then virtual_dsa = "1"b;
	end;
	else dsa_flag = ""b;
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
						/* get new channel */
	if code ^= 0
	then go to ERROR_RETURN;
	attchan = arg;
	if attchan = attchan1
	then do;					/* bad idea */
	     answer = "cannot substty for same channel";
	     go to ANSWER_RETURN;
	end;
	if index (attchan, "dsa.") = 1
	then cdte_flag = ""b;
	else if (index (attchan, ".") ^= 0) | (attchan = "otw_")
	     then do;
	     call check_acceptable (code);
	     if code ^= 0
	     then go to ANSWER_RETURN;		/* answer set up by check_acceptable */

	     if attchan ^= "otw_"
	     then cdte.current_service_type = MC_SERVICE;	/* mark as belonging to MC */
	     cdte_flag = "1"b;
	end;

	if dsa_flag then call process_dsa_ute ((attchan1));

	answer = "removing channel " || attchan1;
	call mc_commands_$substty (attchan1, attchan, cdte_flag, arg_ptr,
	     "1"b, code);				/* arg_ptr is actually useless; it's required because
						   turn_on_mc_ and mc_commands_$substty use it to get
						   the value returned from mc_commands_$new_tty */

	if code = error_table_$action_not_performed
	then do;
	     call ioa_$rsnnl ("Channel ^a not dialed to initializer",
		answer, (0), attchan);
	     goto ANSWER_RETURN;
	end;
	if code = error_table_$noentry
	then do;
	     call ioa_$rsnnl ("Channel ^a not configured.", answer, (0),
		attchan1);
	     goto ANSWER_RETURN;
	end;
	else if code ^= 0
	then goto ERROR_RETURN;

	goto RETURN;
%page;
deroute:
     entry options (variable);

/**** Operator "deroute" command.  Deletes an entry in the Message Routing
      Table. */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: deroute";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get source */
	if code ^= 0
	then go to ERROR_RETURN;
	source = arg;
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
						/* get stream */
	if code ^= 0
	then go to ERROR_RETURN;
	stream = arg;
	call cu_$arg_ptr_rel (3, arg_ptr, arg_length, code, arg_list_ptr);
						/* get vcon */
	if code ^= 0
	then go to ERROR_RETURN;
	vcon = arg;
	answer = "deroute unsuccessful.";
	call mc_commands_$deroute (source, stream, vcon, code);
	if code ^= 0
	then go to ERROR_RETURN;
	go to RETURN;

/* REROUTE - modify entry in Message Routing Table */

reroute:
     entry options (variable);
	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: reroute";
	call validate;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get source */
	if code ^= 0
	then go to ERROR_RETURN;
	source = arg;
	call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code, arg_list_ptr);
						/* get stream */
	if code ^= 0
	then go to ERROR_RETURN;
	stream = arg;
	call cu_$arg_ptr_rel (3, arg_ptr, arg_length, code, arg_list_ptr);
						/* get old vcon */
	if code ^= 0
	then go to ERROR_RETURN;
	vcon = arg;
	call cu_$arg_ptr_rel (4, arg_ptr, arg_length, code, arg_list_ptr);
						/* get new vcon */
	if code ^= 0
	then go to ERROR_RETURN;
	if substr (arg, 1, 1) = "*"
	then do;					/* ring bell? */
	     attype = "alarm";
	     vcon1 = substr (arg, 2);
	end;
	else do;					/* no */
	     attype = "";
	     vcon1 = arg;
	end;
	answer = "reroute unsuccessful.";
	call mc_commands_$reroute (source, stream, vcon, vcon1, attype, code);
	if code ^= 0
	then go to ERROR_RETURN;
	go to RETURN;
%page;

drop:
     entry options (variable);

/**** Operator "drop" command.  Removes a terminal from the message
      coordinator. */

          dutp = as_data_$dutp;	
          iutep = addr (dutbl.entry (1));		/* Initializer's utep for audit */

	arg_list_ptr = cu_$arg_list_ptr ();
	comname = "operator_mc_cmds_: drop";				/* set up command name */
	call validate;				/* locate anstbl */
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get channel */
	if code ^= 0
	then go to ERROR_RETURN;

	attchan = arg;
	virtual_dsa = ""b;
	if (index (attchan, "dsa.") = 1) | (index (attchan, ".") = 0) then do;
	     dsa_flag = "1"b;
	     if index (attchan, ".") = 0 then virtual_dsa = "1"b;
	end;
	else dsa_flag = ""b;

	cdtep = null;
	answer = "drop unsuccessful.";

	if dsa_flag then call process_dsa_ute (attchan);
	else call mc_commands_$remove_tty (attchan, "1"b, code);
						/* get rid of tty */
	if code = error_table_$action_not_performed
	then do;
	     call ioa_$rsnnl ("Channel ^a not dialed to initializer",
		answer, (0), attchan);
	     goto ANSWER_RETURN;
	end;
	if code = error_table_$noentry
	then do;
	     call ioa_$rsnnl ("Channel ^a not configured.", answer, (0),
		attchan);
	     goto ANSWER_RETURN;
	end;
	if code = error_table_$ioname_not_found
	then do;
	     call ioa_$rsnnl (
		"Channel ^a not a message coordinator terminal.",
		 answer, (0), attchan);
	     goto ANSWER_RETURN;
	end;
	else if code ^= 0
	then goto ERROR_RETURN;
		
	call AUDIT_OK ();
	go to RETURN;

%page;
/*   THAT'S IT FOLKS!   */

ERROR_RETURN:
	call sys_log_$command_error (SL_TYPE, code, comname, answer);
	go to RETURN;

ANSWER_RETURN:
	call sys_log_$command (SL_TYPE, "^a: error: ^a", comname, answer);
	go to RETURN;

RETURN:
	return;					/* almost all entries exit here */

/* INTERNAL PROCEDURES */

validate:
     proc;

	if ^sc_stat_$Multics_typed
	then as_data_$sysdir = sc_stat_$sysdir;

	if as_data_$ansp = null
	then do;
	     call hcs_$initiate (sysdir, "answer_table", "", 0, 0, as_data_$ansp, code);
	     as_procid = get_process_id_ ();
	     if as_data_$ansp = null
	     then do;
		call sys_log_$command_error (SL_LOG_BEEP, code, comname, "^a>answer_table", sysdir);
		go to RETURN;
	     end;
	end;
	ansp = as_data_$ansp;

	if whoptr = null
	then do;
	     call hcs_$initiate (sysdir, "whotab", "", 0, 0, whoptr, code);
	     if whoptr = null
	     then call sys_log_$command_error (SL_LOG_BEEP, code, comname, "^a>whotab", sysdir);
	end;
	if ip = null
	then do;
	     call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, code);
	     if ip = null
	     then call sys_log_$command_error (SL_LOG_BEEP, code, comname, "^a>installation_parms", sysdir);
	end;
	if scdtp = null
	then do;
	     call hcs_$initiate (sysdir, "cdt", "", 0, 1, scdtp, code);
	     if scdtp = null
	     then call sys_log_$command_error (SL_LOG_BEEP, code, comname, "^a>cdt", sysdir);
	end;
	call cu_$arg_count_rel (arg_count, arg_list_ptr, (0));
						/* AF invocation not an issue */
	return;					/* end of setup */
     end validate;
%page;

/* Internal procedure to check that channel given as argument to operator
   ACCEPT and SUBSTTY commands is available.  There are 3 cases:
   1) The CMF specified "service: mc;"
   2) The operator typed "dial system" on the terminal
   3) The operator typed "slave" on the terminal
   All other cases are rejected.
*/

check_acceptable:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

	P_code = 0;
	if attchan = "otw_"
	then return;				/* "The" console is always cool */

	cdtep = FIND_CDTE (attchan);
	if cdtep ^= null ()
	then do;
	     if cdte.current_service_type = MC_SERVICE
	     then return;
	     else if cdte.current_service_type = SLAVE_SERVICE
	     then return;
	     else if cdte.current_service_type = INACTIVE
	     then return;				/* drop sets it to INACTIVE. Allow accept to get it back */
	     else do;				/* AS or FTP line. don't mess */
		P_code = 2;
		answer = "channel not available";
		return;
	     end;
	end;
	P_code = 2;
	answer = "channel not defined in cdt.";
	return;
     end check_acceptable;
%page;
FIND_CDTE:
     procedure (P_channel_name) returns (ptr);

dcl  P_channel_name	        char (*) parameter;

dcl  cdtep	        ptr automatic;
dcl  i		        fixed bin (17) automatic;

	do i = 1 to scdtp -> cdt.current_size;
	     cdtep = addr (scdtp -> cdt.cdt_entry (i));
	     if cdtep -> cdte.in_use > NOW_FREE
	     then if cdtep -> cdte.name = P_channel_name
		then return (cdtep);
	end;
	return (null ());
     end FIND_CDTE;

process_dsa_ute:
	procedure (chan_name);

dcl  chan_name		char (32) parm;
dcl  i                        fixed bin;
dcl  continue                 bit (1);

	continue = "1"b;
	if virtual_dsa then do;
	     call initiate_file_ (sysdir, "mc_anstbl", R_ACCESS, mc_ansp, (0), code);
	     if mc_ansp = null then do;
		call ioa_$rsnnl ("trying to access ^a>mc_anstbl", answer, (0), sysdir);
		goto ERROR_RETURN;
	     end;
	     do i = 1 to mc_anstbl.current_size while (continue);
		mc_atep = addr (mc_anstbl.entry (i));
		if chan_name = mc_ate.virtual_tty_name then do;
		     chan_name = mc_ate.real_tty_name;
		     continue = ""b;
		end;
	     end;
	     call terminate_file_ (mc_ansp, 0, TERM_FILE_TERM, (0));
	end;

	continue = "1"b;
	do i = 1 to anstbl.current_size while (continue);
	     utep = addr (anstbl.entry (i));
	     if ute.active = NOW_LOGGED_IN
		then do;
		if chan_name = ute.tty_name
		     then do;
		     if comname = "operator_mc_cmds_: substty" then do;
			if ute.login_flags.operator then ute.login_flags.operator = ""b;
			else if ute.login_flags.special_pw.dial_pw then
			     ute.login_flags.special_pw.dial_pw = ""b;
		     end;

		     call asu_$bump_user (utep, "", code, 0);
		     if code = error_table_$action_not_performed then code = 0;
		     else if code ^= 0 then do;
			answer = "removing user (no proc) on channel " || chan_name;
			goto ERROR_RETURN;
		     end;
		     continue = ""b;
		end;
	     end;
	end;

   end process_dsa_ute;
%page;
AUDIT_OK:
     procedure ();

dcl     action fixed bin (17);

          if rtrim(comname) = "operator_mc_cmds_: attach" then
	     action = AS_AUDIT_CHANNEL_ATTACH;
	else do;
	     action = AS_AUDIT_CHANNEL_DETACH;
	     if cdtep = null then cdtep = FIND_CDTE ((attchan));		/* Hasn't been established for drop */
	end;

	CAI.channel_name = cdte.name;
	CAI.valid = FALSE;
	CAI.valid.service_info = FALSE;
	CAI.service_info = "system";
	CAI.valid.access_class = TRUE;
	CAI.access_class = FALSE;
	CAI.valid.access_class_range = FALSE;
	CAI.access_class_range = get_process_access_class_ ();
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = iutep->ute.initial_ring;

	call as_access_audit_$channel (cdtep, null, iutep, action, addr (CAI), "");
     end AUDIT_OK;

%page; %include access_audit_bin_header;
%page; %include access_mode_values;
%page; %include answer_table;
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include author_dcl;
%page; %include cdt;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include login_server_messages;
%page; %include mc_anstbl;
%page; %include mc_restriction_codes;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include terminate_file;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page;
/* BEGIN MESSAGE DOCUMENTATION
   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>answer_table

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the answer_table in SYSDIR.

   A:	$inform


   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>whotab

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the whotab in SYSDIR.

   A:	$inform


   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>installation_parms

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the installation_parms in SYSDIR.

   A:	$inform


   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>cdt

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the cdt in SYSDIR.

   A:	$inform


   Message:
   operator_mc_cmds_: accept: error:  unknown privilege code

   S:	$as1

   T:	In response to an operator accept command.

   M:	The operator has typed accept CHANNEL PRIVILEGE but PRIVILEGE is
   not a known privilege code.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE Usage: accept channel_id {authority} {target} {broadcast_list}

   S:	$as1

   T:	In response to an operator accept command.

   M:	The operator has issued an accept command without any arguments.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE Failed to accept CHANNEL.

   S:	$as1

   T:	In response to an operator accept command.

   M:	The operator has issued an accept CHANNEL command, but CHANNEL cannot
   be accepted.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept:  CHANNEL set to "full".

   S:	$as1

   T:	In response to an operator accept command.

   M:	CHANNEL is already in use and authorization request has not changed
   from it's current state.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE Channel CHANNEL is not in
   Message Coordinator service.

   S:	$as1

   T:	In response to an operator accept command.

   M:	CHANNEL cannot be accepted as a message coordinator terminal.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE Failed to set restriction to RESTRICTION.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Failed to set the reply restriction.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE Failed to reset restriction.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Failed to reset the reply restriction.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE Failed to set broadcast list to BROADCAST_LIST.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Failed to set the broadcast list BROADCAST_LIST.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE This name is reserved for the system console.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Attempt to accept identifier "otw_" which is THE identifier for the
   master console, which is automatically accepted on bootload.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: channel not available

   S:	$as1

   T:	In response to an operator accept command.

   M:	Channel cannot be used as a message coordinator channel.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: channel not defined in cdt.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Channel is not found in the system cdt and therefore cannot be used.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: Ioname already attached and active. accept unsuccessful.

   S:	$as1

   T:	In response to an operator accept command.

   M:	The error was returned from mc_commands_$new_tty causing the accept
   to abort. 

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: ERROR_TABLE_MESSAGE accept unsuccessful.

   S:	$as1

   T:	In response to an operator accept command.

   M:	The error was returned from mc_commands_$new_tty causing the accept
   to abort. 

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept: Ioname not found. accept unsuccessful.

   S:	$as1

   T:	In response to an operator accept command.

   M:	The error was returned from mc_commands_$new_tty causing the accept
   to abort. Channel not found in the cdt or pre-accepted as a virtual channel.

   A:	$tryagain


   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE Incorrect number of arguments.

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Insufficient number of arguments supplied with the command.

   A:	$tryagain


   Message:
   operator_mc_cmds_: drop: error: Channel CHANNEL not a message coordinator terminal.

   S:	$as1

   T:	$response

   M:	Cannot drop CHANNEL as it cannot be found attached to the message coordinator.

   A:	$inform


   Message:
   operator_mc_cmds_: drop: error: Channel CHANNEL not configured.

   S:	$as1

   T:	$response

   M:	Channel CHANNEL is not defined in the system cdt.

   A:	$inform


   Message:
   operator_mc_cmds_: drop: error: Channel CHANNEL not dialed to initializer.

   S:	$as1

   T:	$response

   M:	CHANNEL must be dialed to the initializer before being dropped.

   A:	$inform


   Message:
   operator_mc_cmds_: drop: ERROR_TABLE_MESSAGE drop unsuccessful.

   S:	$as1

   T:	In response to an operator drop command.

   M:	An error was returned from mc_commands_$remove_tty causing the drop
   to abort.

   A:	$tryagain

   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE removing user (no proc) on channel CHANNEL

   S:     $as1

   T:     $response

   M:     An error described by ERROR_TABLE_MESSAGE occured while attempting
   the operator command, COMMAND.

   A:     $inform

   Message:
   operator_mc_cmds_: COMMAND: ERROR_TABLE_MESSAGE trying to access SYSDIR>mc_anstbl

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:     The system was not able to access the mc_anstbl in SYSDIR.

   A:	$inform


   Message:
   operator_mc_cmds_: substty: error: cannot substty for same channel

   S:	$as1

   T:	In response to an operator substty command.

   M:	The operator has attempted to use substty to substitute
   a channel for itself.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: error: channel not available

   S:	$as1

   T:	In response to an operator accept command.

   M:	Channel cannot be used as a message coordinator channel.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: error: channel not defined in cdt.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Channel is not found in the system cdt and therefore cannot be used.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty:  ERROR_TABLE_MESSAGE removing channel CHANNEL

   S:	$as1

   T:	In response to an operator substty command.

   M:	Unable to remove CHANNEL designated as the source of the substitution.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: Channel CHANNEL not dialed to initializer

   S:	$as1

   T:	In response to an operator substty command.

   M:	Channel CHANNEL was not previously dialed to the initializer and thus
   cannot be substituted.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: Channel CHANNEL not configured.

   S:	$as1

   T:	In response to an operator substty command.

   M:	Channel CHANNEL is not found in the system cdt.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: ERROR_TABLE_MESSAGE substty unsuccessful.

   S:	$as1

   T:	In response to an operator substty command.

   M:	An error was returned from mc_commands_$substty causing the substty
   to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: Ioname not found. substty unsuccessful.

   S:	$as1

   T:	In response to an operator substty command.

   M:	An error was returned from mc_commands_$substty causing the substty
   to abort.  Could not locate source channel in mc_anstbl.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: Ioname not found. substty unsuccessful.

   S:	$as1

   T:	In response to an operator substty command.

   M:	The error was returned from mc_commands_$new_tty causing the substty
   to abort. The target channel not found in the cdt or pre-accepted as a
   virtual channel.

   A:	$tryagain


   Message:
   operator_mc_cmds_: substty: The requested action was not performed. substty unsuccessful.

   S:	$as1

   T:	In response to an operator substty command.

   M:	An error was returned from mc_commands_$substty causing the substty
   to abort. The target channel is in a "pending" state, which means it has
   not been accepted yet.

   A:	$tryagain


   Message:
   operator_mc_cmds_: redefine: ERROR_TABLE_MESSAGE redefine unsuccessful.

   S:	$as1

   T:	In response to an operator redefine command.

   M:	An error was returned from mc_commands_$redefine causing the redefine
   to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: redefine: Ioname not found. redefine unsuccessful.

   S:	$as1

   T:	In response to an operator redefine command.

   M:	An error was returned from mc_commands_$redefine causing the redefine
   to abort. Could not locate VCONS in vcons_tab.

   A:	$tryagain


   Message:
   operator_mc_cmds_: redefine: Ioname not active. redefine unsuccessful.

   S:	$as1

   T:	In response to an operator redefine command.

   M:	An error was returned from mc_commands_$redefine causing the redefine
   to abort. Target channel not active in the mc_anstbl.

   A:	$tryagain


   Message:
   operator_mc_cmds_: redefine: Action not performed. redefine unsuccessful.

   S:	$as1

   T:	In response to an operator redefine command.

   M:	An error was returned from mc_commands_$redefine causing the redefine
   to abort. Target channel found requiring an accept in mc_anstbl.

   A:	$tryagain


   Message:
   operator_mc_cmds_: redefine: Typename not found. redefine unsuccessful.

   S:	$as1

   T:	In response to an operator redefine command.

   M:	An error was returned from mc_commands_$redefine causing the redefine
   to abort. Target VCONS type not known.

   A:	$tryagain


   Message:
   operator_mc_cmds_: redefine: Allocation could not be performed. redefine unsuccessful.

   S:	$as1

   T:	In response to an operator redefine command.

   M:	The operator has issued a redefine VCONS SOURCE STREAM VCONS
   command but the system could not make the new entry in the
   message routing table.  No action was taken.

   A:	$tryagain


   Message:
   operator_mc_cmds_: define: ERROR_TABLE_MESSAGE define unsuccessful.

   S:	$as1

   T:	In response to an operator define command.

   M:	An error was returned from mc_commands_$define causing the define
   to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: define: Ioname not found. define unsuccessful.

   S:	$as1

   T:	In response to an operator define command.

   M:	An error was returned from mc_commands_$define causing the define
   to abort. Could not locate VCONS in vcons_tab.

   A:	$tryagain


   Message:
   operator_mc_cmds_: define: Ioname not active. define unsuccessful.

   S:	$as1

   T:	In response to an operator define command.

   M:	An error was returned from mc_commands_$define causing the define
   to abort. Target channel not active in the mc_anstbl.

   A:	$tryagain


   Message:
   operator_mc_cmds_: define: Action not performed. define unsuccessful.

   S:	$as1

   T:	In response to an operator define command.

   M:	An error was returned from mc_commands_$define causing the define
   to abort. Target channel found requiring an accept in mc_anstbl.

   A:	$tryagain


   Message:
   operator_mc_cmds_: define: Typename not found. define unsuccessful.

   S:	$as1

   T:	In response to an operator define command.

   M:	An error was returned from mc_commands_$define causing the define
   to abort. Target VCONS type not known.

   A:	$tryagain


   Message:
   operator_mc_cmds_: define: There is no room to make requested allocations.

   S:	$as1

   T:	In response to an operator define command.

   M:	The operator has issued a define SOURCE STREAM VCONS
   command but the system could not make the new entry in the
   message routing table.  No action was taken.

   A:	$tryagain


   Message:
   operator_mc_cmds_: route: There is no room to make requested allocations.

   S:	$as1

   T:	In response to an operator route command.

   M:	The operator has issued a route SOURCE STREAM VCONS command
   but the system had no room to make the new entry in the message
   routing table.  There may be up to 16 sources, each with 8 streams,
   and each stream may have up to 8 virtual consoles.  No action was taken.

   A:	$tryagain


   Message:
   operator_mc_cmds_: route: ERROR_TABLE_MESSAGE route unsuccessful.

   S:	$as1

   T:	In response to an operator route command.

   M:	An error was returned from mc_commands_$route causing the route
   to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: route: Ioname not found. route unsuccessful.

   S:	$as1

   T:	In response to an operator route command.

   M:	An error was returned from mc_commands_$route causing the route
   to abort. VCONS not located in vcons_tab.

   A:	$tryagain


   Message:
   operator_mc_cmds_: undefine: ERROR_TABLE_MESSAGE undefine unsuccessful.

   S:	$as1

   T:	In response to an operator undefine command.

   M:	An error was returned from mc_commands_$undefine causing the
   undefine to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: undefine: Ioname not found. undefine unsuccessful.

   S:	$as1

   T:	In response to an operator undefine command.

   M:	An error was returned from mc_commands_$undefine causing the
   undefine to abort. Could not locate VCONS in vcons_tab.

   A:	$tryagain


   Message:
   operator_mc_cmds_: reroute: ERROR_TABLE_MESSAGE reroute unsuccessful.

   S:	$as1

   T:	In response to an operator reroute command.

   M:	An error was returned from mc_commands_$reroute causing the
   reroute to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: reroute: There is no room to make requested allocations.

   S:	$as1

   T:	In response to an operator reroute command.

   M:	The operator has issued a reroute SOURCE STREAM OLD_VCONS
   NEW_VCONS command but the system had no room to make the new entry
   in the message routing table.  There may be up to 16 sources, each
   with 8 streams, and each stream may have up to 8 virtual consoles.
   No action was taken.

   A:	$tryagain


   Message:
   operator_mc_cmds_: deroute: ERROR_TABLE_MESSAGE reroute unsuccessful.

   S:	$as1

   T:	In response to an operator deroute command.

   M:	An error was returned from mc_commands_$deroute causing the
   deroute to abort.

   A:	$tryagain


   Message:
   operator_mc_cmds_: deroute: There is no room to make requested allocations.

   S:	$as1

   T:	In response to an operator deroute command.

   M:	The operator has issued a deroute SOURCE STREAM VCONS
   command but the system had no room to make the new entry
   in the message routing table.  There may be up to 16 sources, each
   with 8 streams, and each stream may have up to 8 virtual consoles.
   No action was taken.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: ERROR_TABLE_MESSAGE Usage: accept_vchn
     channel_id -auth authority -target reply_target -bc_list input_broadcast_list

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	Incorrect number of arguments supplied.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Incorrect IO channel specification. DOT  Virtual channel names may not contain a DOT

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	The DOT (".") character cannot be used in the virtual channel specifier.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Incorrect IO channel specification.
   This name is reserved for the system console.

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	The specified virtual channel name given was "otw_".  This identifier
   cannot be used as it identifies the system console.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Invalid argument  -auth may be followed by one of the following:
   full, none, reply, daemon, query

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	An incorrect argument to the -auth control argument was supplied.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Invalid argument  Bad reply target: TARGET

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	An incorrect argument to the -reply control argument was supplied.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Specified control argument is not accpeted
   Argument not accepted: ARGUMENT

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	An incorrect control argument was supplied to the accept_vchn request.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: ERROR_TABLE_MESSAGE  Failed to accept VCHANNEL

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	Unable to pre-accept VCHANNEL as a virtual channel identifier.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Invalid argument  Bad broadcast list: BROADCAST_LIST

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	Incorrect argument supplied to the -bc_list control argument.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: Ioname already attached and active. 
   VCHANNEL set to full.

   S:	$as1

   T:	In response to an operator accept_vchn command.

   M:	VCHANNEL already active and authorization request is same.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: ERROR_TABLE_MESSAGE Failed to set restriction to REPLY_TARGET

   S:	$as1

   T:	In response to an operator accept command.

   M:	Failed to set the reply restriction for REPLY_TARGET.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: ERROR_TABLE_MESSAGE Failed to reset restriction.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Failed to reset the reply restriction.

   A:	$tryagain


   Message:
   operator_mc_cmds_: accept_vchn: ERROR_TABLE_MESSAGE Failed to set broadcast list to BROADCAST_LIST.

   S:	$as1

   T:	In response to an operator accept command.

   M:	Failed to set the broadcast list for BROADCAST_LIST.

   A:	$tryagain


   END MESSAGE DOCUMENTATION */

     end operator_mc_cmds_;




		    operator_process_cmds_.pl1      06/07/89  1233.5rew 06/07/89  1232.2      276678



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-12-05,MSharpe), approve(87-07-09,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Original coding.  Moved the process-related commands out of admin_.
     Added functionality to these commands to recognize dsa channel names
     on the command line and to bump by process_id.  The structure of the
     original programs has been heavily modified.
     CDD 86-03-11 - fixed bugs in bumping by PID
     86-03-12     - fixed bug in reporting dsa channel name; to accept
      the first 6 digits of pid.
  2) change(87-04-26,GDixon), approve(87-07-09,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  3) change(87-05-28,Parisek), approve(87-07-09,MCR7690),
     audit(87-08-03,Beattie), install(87-08-04,MR12.1-1055):
     Correct an incorrectly formatted ioa_ control string.
  4) change(87-06-29,Parisek), approve(87-06-29,MCR7690),
     audit(87-08-03,Beattie), install(87-08-04,MR12.1-1055):
     Ignore error_table_$action_not_performed returned from asu_$bump_user if
     dsa channel.
  5) change(88-08-18,Parisek), approve(88-09-08,MCR7979),
     audit(88-09-08,Farley), install(88-09-09,MR12.2-1101):
     Bump dsa starname channels (ie, dsa.MULF.*) if code returned from
     match_star_name_ is zero, not non-zero (bug).  If bumping based on
     code ^= 0 then all users will get bumped instead of the specified
     dsa channels.
  6) change(89-04-20,Lee), approve(89-05-10,MCR8106), audit(89-05-11,Farley),
     install(89-06-07,MR12.3-1053):
     Modified to ensure arg_index and bump_by_name are initialized properly
     after the target specifier gets parsed and "mpx" or "fnp" was specified
     for the target; modified bump to not treat bump *.* as taking the action
     "shutdown"; no code had existed to handle "shutdown" so bump was failing.
     Cosmetic changes to this fix based on Paul Farley's original solution,
     which was developed independently.
                                                   END HISTORY COMMENTS */
/* format: style4,indattr */

operator_process_cmds_:
	procedure ();

/* The following five entry points provide commands to change the state of
   a tty channel and/or the process using the channel: detach, terminate,
   bump, unbump.

   The programs share common code and usage (except that only bump accepts
   a grace time argument). The usage is:
   *	COMMAND  PERS PROJ GRACETIME MESSAGE...
   *	   "     CHANNEL               "
   *	   "     fnp TAG               "

   where PERS and PROJ can be "*" indicating "all".

   These commands operate by sending a wakeup with the action word (bump,
   unbump, detach, terminat, hangup) being contained in the event message.

   The wakeup is handled by dialup_, which takes the action specified by
   the action word.  The warning message, if any, is printed on the user's
   terminal before the wakeup is sent.  If the process is not past the
   login stage, hcs_$wakeup is used to send the wakeup.  Otherwise,
   asu_$bump_user is called, and that procedure sets ate.preempted = 2,
   prints the message, and sets an event timer to go off when the specified
   grace time has expired.  The event message will be "alarm___" in this
   case, but dialup_ detects a bump by seeing that ate.preempted > 0.  The
   unbump code in dialup_ just sets ate.preempted = 0, so that when the
   alarm___ goes off, dialup_ returns instead of bumping the user.
   
   The command arguments are processed as follows:

    #of components	      arg		category to bump by
     (#of dots +1)
	 1	    fnp  or
		    mpx 		mpx -- the next arg is mpx name

	 2	    *.*		name
	 2	    dsa.{anything}	first by name, if not, by dsa channel
	 2	    {any other}	first by name, if not, by tty channel

	 3+	    dsa.{anything}	by dsa channel
	 3+	    {any other}	by tty channel

   If the "bump" command is issued, the next argument is tested for a
   numeric value -- number of minutes of grace time.  The rest of the
   arguments are strung together and displayed on the user's terminal
   before he's bumped.

*/


%page;

/*  AUTOMATIC */

dcl  action	        char (8) aligned;
dcl  action_log	        char (12) aligned;
dcl  answer	        char (256) init ("");
dcl  arg_count	        fixed bin (17);
dcl  arg_index	        fixed bin (17);
dcl  arg_length	        fixed bin (21);
dcl  arg_list_ptr	        ptr;
dcl  arg_ptr	        ptr;
dcl  bin_pid	        fixed bin (35);
dcl  bump_by_chn_id	        bit (1);
dcl  bump_by_dsa	        bit (1);
dcl  bump_by_mpx	        bit (1);
dcl  bump_by_name	        bit (1);
dcl  bump_by_pid	        bit (1);
dcl  code		        fixed bin (35);
dcl  comname	        char (48) aligned varying;
dcl  fnp_only	        bit (1);
dcl  input_channel	        char (32);			/* channel id to look for */
dcl  input_person_id        char (28);			/* person id to look for */
dcl  input_pid	        bit (36);			/* proc_id to look for */
dcl  input_project_id       char (28);			/* proj id to look for */
dcl  msg_string	        char (256);
dcl  msg_string_len	        fixed bin;			/* actual length of msg_string */
dcl  mpx_name	        char (32);			/* name of a mltiplexer */
dcl  mpx_starname	        char (32);
dcl  respect_nobump	        bit (1);
dcl  grace_period	        fixed bin;

/* BASED */

dcl  arg		        char (arg_length) based (arg_ptr);

/* BUILTIN */

dcl  (addr, index, length, null, rtrim, substr, unspec) builtin;


/* ENTRY */

dcl  asu_$blast_user        entry (ptr, char (*), char (*), fixed bin (35));
dcl  asu_$bump_user	        entry (ptr, char (*), fixed bin (35), fixed bin);
dcl  asu_$unbump_user       entry (ptr, fixed bin (35));
dcl  asu_$terminate_user    entry (ptr, fixed bin (35));
dcl  asu_$detach_user       entry (ptr, fixed bin (35));
dcl  asu_$disconnect_user   entry (ptr, fixed bin (35));
dcl  cu_$arg_count_rel      entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_list_ptr       entry () returns (ptr);
dcl  cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21),
		        fixed bin (35), ptr);
dcl  cv_dec_check_	        entry (char (*), fixed bin (35))
		        returns (fixed bin (35));
dcl  cv_oct_check_	        entry (char (*), fixed bin (35))
		        returns (fixed bin (35));
dcl  get_process_id_        entry () returns (bit (36));
dcl  hcs_$initiate	        entry (char (*), char (*), char (*), fixed bin (1),
		        fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$wakeup	        entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ioa_$rsnnl	        entry options (variable);
dcl  match_star_name_       entry (char (*), char (*), fixed bin (35));
dcl  sys_log_$command       entry options (variable);
dcl  sys_log_$command_error entry options (variable);

/* Static */

dcl  error_table_$action_not_performed fixed bin (35) ext static;

%page;

detach: entry options (variable);

/**** This entry implements the operator "detach" command.  It forceably
      logs out a user and makes the tty unresponsive */

	arg_list_ptr = cu_$arg_list_ptr ();
	call process_bump_args (arg_list_ptr, ""b);

	action = "detach";
	action_log = "detached";
	comname = "operator_process_cmds_: detach";

	call process_bump_args (arg_list_ptr, ""b);

	respect_nobump = ""b;
	call bump_procedure ();

	go to RETURN;

%page;
terminate: entry options (variable);

/**** This entry implements the operator "terminate" command.  It forceably
       terminates the user's process and creates a new one */


	arg_list_ptr = cu_$arg_list_ptr ();

	action = "terminat";
	action_log = "terminated";
	comname = "operator_process_cmds_: terminate";

	call process_bump_args (arg_list_ptr, ""b);

	respect_nobump = ""b;
	call bump_procedure ();

	go to RETURN;

%page;
bump: entry options (variable);

/**** This entry implements the operator "bump" command.  It forceably
      logs out a user. */

	arg_list_ptr = cu_$arg_list_ptr ();

	action = "bump    ";
	action_log = "bumped";
	comname = "operator_process_cmds_: bump";

	call process_bump_args (arg_list_ptr, "1"b);

	respect_nobump = "1"b;

	call bump_procedure ();

	go to RETURN;
%page;
unbump: entry options (variable);

/**** This entry implements the operator "unbump" command.  */

	arg_list_ptr = cu_$arg_list_ptr ();

	action = "unbump";
	action_log = "unbumped";
	comname = "operator_process_cmds_: unbump";

	call process_bump_args (arg_list_ptr, ""b);

	respect_nobump = ""b;
	call bump_procedure ();

	go to RETURN;
%page;
disconnect: entry options (variable);

/**** This entry implements the operator "disconnect" command.  It
      causes a hangup to be simulated for the user's channel which
      either disconnects, or logs out the user. */

	arg_list_ptr = cu_$arg_list_ptr ();

	action = "hangup";
	action_log = "disconnected";
	comname = "operator_process_cmds_: disconnect";

	call process_bump_args (arg_list_ptr, ""b);

	respect_nobump = ""b;
	call bump_procedure ();

	go to RETURN;

%page;
/*   THAT'S IT FOLKS!   */

ERROR_RETURN:
	call sys_log_$command_error (SL_TYPE, code, comname, answer);
	go to RETURN;

ANSWER_RETURN:
	call sys_log_$command (SL_TYPE, "^a: error: ^a", comname, answer);
	go to RETURN;

RETURN:
	return;					/* almost all entries exit here */

/* Internal Procedures */
%page;

general_setup:
     proc ();

	if ^sc_stat_$Multics_typed
	then as_data_$sysdir = sc_stat_$sysdir;

	if as_data_$ansp = null
	then do;
	     call hcs_$initiate (sysdir, "answer_table", "", 0, 0,
		as_data_$ansp, code);
	     as_procid = get_process_id_ ();
	     if as_data_$ansp = null
	     then do;
		call sys_log_$command_error (SL_LOG_BEEP, code, comname,
		     "^a>answer_table", sysdir);
		go to RETURN;
	     end;
	end;
	ansp = as_data_$ansp;

	if whoptr = null
	then do;
	     call hcs_$initiate (sysdir, "whotab", "", 0, 0, whoptr, code);
	     if whoptr = null
	     then call sys_log_$command_error (SL_LOG_BEEP, code, comname,
		     "^a>whotab", sysdir);
	end;

	if ip = null
	then do;
	     call hcs_$initiate (sysdir, "installation_parms", "",
		0, 1, ip, code);
	     if ip = null
	     then call sys_log_$command_error (SL_LOG_BEEP, code, comname,
		"^a>installation_parms", sysdir);
	end;

	if scdtp = null
	then do;
	     call hcs_$initiate (sysdir, "cdt", "", 0, 1, scdtp, code);
	     if scdtp = null
	     then call sys_log_$command_error (SL_LOG_BEEP, code, comname,
		     "^a>cdt", sysdir);
	end;

	call cu_$arg_count_rel (arg_count, arg_list_ptr, (0));
						/* AF invocation not an issue */
	return;					/* end of setup */

     end general_setup;
%page;
build_string:
     proc (P_arg_list_ptr, P_argno);

dcl  P_arg_list_ptr	        pointer parameter;
dcl  P_argno	        fixed bin parameter;		/* arg number to start from */
dcl  argno	        fixed bin;

	argno = P_argno;
	answer = "Incorrect number of arguments.";
	call cu_$arg_ptr_rel (argno, arg_ptr, arg_length, code,
	     P_arg_list_ptr);

	if code ^= 0
	then go to ERROR_RETURN;

	msg_string = arg;
	msg_string_len = arg_length;

build:
	argno = argno + 1;
	call cu_$arg_ptr_rel (argno, arg_ptr, arg_length, code,
	     P_arg_list_ptr);

	if code ^= 0 then return;

	substr (msg_string, msg_string_len + 2) = arg;
	msg_string_len = msg_string_len + 1 + arg_length;
	if msg_string_len > length (msg_string)
	then return;

	go to build;

     end build_string;
%page;
process_bump_args: procedure (arg_list_ptr, grace_flag);

/* Internal procedures should not call this procedure.  Instead, they
   should call internal_bump, or a program like it, which will call us.  */

dcl  arg_list_ptr	        ptr parameter;		/* pointer to our caller's argument list */
dcl  grace_flag	        bit (1) aligned parameter;
						/* grace period arg allowed ? (Input) */


dcl  i		        fixed bin (17);		/* temporary */
dcl  dot_index	        fixed bin (17);

	call general_setup;				/* locate answer table; some housekeeping */

	bump_by_chn_id, bump_by_dsa, bump_by_mpx,
	     bump_by_pid = ""b;			/* set switches ... */
	bump_by_name = "1"b;			/* we'll try by_name unless proven innocent! */

	call cu_$arg_ptr_rel (1, arg_ptr, arg_length, code, arg_list_ptr);
						/* get first argument */
	if code ^= 0 then do;
BUMP_ETC_USAGE:
	     call ioa_$rsnnl ("Usage: ^a (Person.Project|CHANNEL|mpx MPX|-pid PID) {TIME MESSAGE}",
		answer, (0), comname);
	     go to ANSWER_RETURN;
	end;

	if substr (arg, 1, 9) = "anonymous"
	then do;
	     input_person_id = substr (arg, 1, 9);
	     if (arg_length > 10) & (index (arg, ".") = 10)
	     then input_project_id = substr (arg, 11);
	     else goto BUMP_ETC_USAGE;
	end;

	dot_index = index (arg, ".");

	if dot_index = 0 then do;			/* only by mpx, fnp */
	     if arg = "fnp" | arg = "mpx"
	     then do;
		fnp_only = (arg = "fnp");
		input_person_id = arg;		/* for use in error messages */
		call get_mpx_name (2);		/* Multiplexer name should be arg 2 */
		bump_by_mpx = "1"b;
		input_project_id = rtrim(mpx_name);
		input_channel = "";
		mpx_starname = rtrim (mpx_name) || ".**";
	     end;
	     else if (arg = "-process_id") | (arg = "-pid")
	     then do;
		call cu_$arg_ptr_rel (2, arg_ptr, arg_length, code,
		     arg_list_ptr);			/* get process_id */
		if code ^= 0 then goto BUMP_ETC_USAGE;

		if arg_length ^= 6 & (arg_length ^= 12)
		then goto PID_ERR;
		bin_pid = cv_oct_check_ ((arg), code);	/* octal number? */
		if code = 0
		then do;
		     bump_by_pid = "1"b;
		     input_pid = ""b;
		     if arg_length = 12
		     then input_pid = unspec (bin_pid);
		     else substr (input_pid, 1, 18) = substr (unspec (bin_pid), 19);
		end;
		else do;
PID_ERR:		     answer = "Invalid process id: "|| arg || ".  Use the first 6 or all 12 digits of the pid.";
		     goto ERROR_RETURN;
		end;
	     end;

	     else do;
		call ioa_$rsnnl (
		     "Usage: ^a (Person.Project|CHANNEL|mpx MPX) {TIME MESSAGE}^/The ""Person Project"" format is obsolete.",
		     answer, (0), comname);
		go to ANSWER_RETURN;
	     end;

	     arg_index = 3;				/* grace time, or message, if any, starts with arg 3 */
	     bump_by_name = ""b;

	end;

	else do;
	     input_person_id = substr (arg, 1, dot_index - 1);
	     input_project_id = substr (arg, dot_index + 1);

	     if index (input_project_id, ".") ^= 0	/* if more than two components ... */
	     then do;
		bump_by_name = ""b;			/* it can't be by_name;  */
		input_channel = arg;
	     end;
						/* else, first try by_name, then by tty or dsa channel */
	     if arg ^= "*.*"
	     then do;
		input_channel = arg;

		if input_person_id = "dsa"		/* check first component */
		then bump_by_dsa = "1"b;
		else bump_by_chn_id = "1"b;
	     end;

	     arg_index = 2;
	end;

	grace_period = 0;				/* zero grace */
	msg_string = "";				/* blank message */

	if grace_flag
	then do;
	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code,
		arg_list_ptr);			/* grace period? (minutes) */
	     if code = 0
	     then do;
		i = cv_dec_check_ ((arg), code);
						/* number? */
		if code = 0
		then do;				/* yes. */
		     grace_period = i * 60;		/* convert to seconds */
		     arg_index = arg_index + 1;
						/* step argument index */
		end;
	     end;
	end;

	call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_length, code,
	     arg_list_ptr);				/* message? */


	if code = 0
	then call build_string (arg_list_ptr, arg_index); /* get any remaining args and make message */

	return;

     end process_bump_args;
%page;

get_mpx_name:
     proc (argno);

dcl  argno	        fixed bin;

	call cu_$arg_ptr_rel (argno, arg_ptr, arg_length, code, arg_list_ptr);
	if code ^= 0 then do;
	     if fnp_only
	     then answer = "No FNP tag specified";
	     else answer = "No multiplexer specified";
	     go to ANSWER_RETURN;
	end;

	mpx_name = arg;
	if fnp_only then do;			/* extra checks to be compatable with old commands */
	     if length (rtrim (mpx_name)) > 1
	     then do;
bad_mpx_fnp_name:
		answer = "Invalid FNP tag: " || mpx_name;
		go to ANSWER_RETURN;
	     end;

	     if index ("abcdefgh", substr (mpx_name, 1, 1)) = 0
	     then go to bad_mpx_fnp_name;
	end;

	return;

     end get_mpx_name;

%page;
bump_procedure:
     proc ();

dcl  action_flag	        bit (1) aligned;
dcl  bin_action	        fixed bin (71) aligned based;
dcl  continue	        bit (1);
dcl  i		        fixed bin;

	action_flag = ""b;
	cdtep = null ();
	code = 0;
TRY_AGAIN:
	continue = "1"b;
	if bump_by_name
	then do i = 1 to anstbl.current_size while (continue);
	     utep = addr (anstbl.entry (i));
	     if ute.active >= NOW_LOGGED_IN
	     then do;
		if input_person_id = ute.person | input_person_id = "*"
		then if input_project_id = ute.project | input_project_id = "*"
		     then do;
			bump_by_chn_id, bump_by_dsa = ""b; /* it WAS by name after all */
			call PROCESS_UTE ();
			if input_person_id ^= "*" & input_project_id ^= "*"
			then continue = "0"b;
						/* no need to go further */
		     end;
	     end;
	end;


	else if bump_by_dsa
	then do i = 1 to anstbl.current_size while (continue);
	     utep = addr (anstbl.entry (i));
	     if ute.active >= NOW_LOGGED_IN
	     then do;
		if index (input_channel, "*") > 0
		then do;
		     call match_star_name_ ((ute.tty_name), input_channel, code);
		     if code = 0
		     then call PROCESS_UTE ();
		end;
		else do;				/* no stars */
		     if input_channel = ute.tty_name
		     then do;
			call PROCESS_UTE ();
			continue = "0"b;		/* no need to go further */
		     end;
		end;
	     end;					/* not logged in, skip it */
	end;

	else if bump_by_pid
	then do i = 1 to anstbl.current_size while (continue);
	     utep = addr (anstbl.entry (i));
	     if ute.active >= NOW_LOGGED_IN
	     then do;
		if substr (input_pid, 1, 18) = substr (ute.proc_id, 1, 18)
		then do;
		     call PROCESS_UTE ();
		     continue = "0"b;		/* no need to go further */
		end;
	     end;					/* not logged in, skip it */
	end;

	else do;					/* not bumping by name or dsa */
	     do i = 1 to scdtp -> cdt.current_size while (continue);
		cdtep = addr (scdtp -> cdt.cdt_entry (i));
		if bump_by_mpx
		then do;
		     call match_star_name_ ((cdte.name), mpx_starname, code);
		     if code = 0
		     then call PROCESS_CDTE ();
		end;
		else if cdte.name = input_channel
		then do;
		     call PROCESS_CDTE ();
		     continue = "0"b;		/* no need to go further */
		end;
	     end;
	end;

	if action_flag
	then return;				/* successful */
	else if (bump_by_name & (bump_by_dsa | bump_by_chn_id))
	then do;
	     bump_by_name = ""b;
	     go to TRY_AGAIN;			/* try for a channel match this time */
	end;
	else call sys_log_$command (SL_TYPE,
	     "^a: no ^a signalled to ^[^12.3b^4s^;^s^[^a.^a^s^;^2s^a^]^]",
	      comname, action, bump_by_pid, input_pid, (bump_by_name
	     | bump_by_mpx), input_person_id, input_project_id,
	     input_channel);
	return;

%page;
PROCESS_UTE:
	procedure ();

/**** This procedure is used to perform the desired action on the
      specified ute.  The action is specified via the variable "action".

      It is called either from bump_procedure or PROCESS_CDTE
****/

dcl  chan_name		char (32);

	answer = "Error recieved from AS.";
	if respect_nobump & bump_by_name
	then if ute.at.nobump
	     then do;
		call sys_log_$command (SL_TYPE,
		     "^a: ^[^a.^a^s^;^2s^12.3b^] has ""nobump""", comname,
		     bump_by_name, ute.person, ute.project, ute.proc_id);
		if ^ute.uflags.disconnected
		then call asu_$blast_user (utep, "Bump attempted.  " || msg_string, (""), (0));
		return;
	     end;

	if action = "hangup"
	then if ute.channel = null
	     then return;
	     else do;
		call asu_$disconnect_user (utep, code);
		if code ^= 0 then goto ERROR_RETURN;
	     end;

	else if action = "unbump"
	     then if ute.preempted <= 0
		then return;
		else do;
		     call asu_$unbump_user (utep, code);
		     if code ^= 0 then goto ERROR_RETURN;
		end;

	else if action = "terminat"
	     then do;
		call asu_$terminate_user (utep, code);
		if code ^= 0 then goto ERROR_RETURN;
	     end;

	else if action = "detach"
	     then do;
		call asu_$detach_user (utep, code);
		if code ^= 0 then goto ERROR_RETURN;
	     end;


	else if action = "bump"
	     then do;
		call asu_$bump_user (utep, msg_string, code, grace_period);
		if code = error_table_$action_not_performed & cdtep = null then code = 0;
		else if code ^= 0 then goto ERROR_RETURN;
	     end;

/**** This tells the operator what we did and sets the flag saying that
      we did something. */

	if cdtep = null then chan_name = ute.tty_name;
	else chan_name = cdte.name;

	call sys_log_$command (SL_TYPE,
	     "^a: ^[^12.3b^4s^;^s^[^a.^a^s^;^2s^a^]^] ^a",
	     comname, bump_by_pid, ute.proc_id, bump_by_name, ute.person,
	     ute.project, chan_name, action_log);
	action_flag = "1"b;				/* remember we did one */
	return;

	end PROCESS_UTE;


PROCESS_CDTE:
	procedure ();

/**** This procedure is called to perform the action specified by the
      variable "action" on the specified channel. */

	     utep = cdte.process;
	     if cdte.in_use = NOW_HAS_PROCESS
	     then call PROCESS_UTE ();
	     else if action = "detach"
	     then do;
		if cdte.current_service_type = MC_SERVICE
		then call sys_log_$command (SL_LOG,
			"operator_process_cmds_: detach: Channel ^a is in use by the message coordinator and cannot be detached", cdte.name)
			;
		else if cdte.current_service_type = INACTIVE
		then call sys_log_$command (SL_LOG, "operator_process_cmds_: detach: Channel ^a is not currently active and cannot be detached");
		else do;
		     call hcs_$wakeup (as_procid, cdte.event, addr (action) -> bin_action, code);
		     if code = 0
		     then do;			/* tell operator we did it */
			call sys_log_$command (SL_TYPE, "^a: ^a ^a",
			     comname, cdte.name, action_log);
			action_flag = "1"b;		/* remember we did one */
		     end;
		     else call sys_log_$command_error (SL_LOG, code, comname, "From hcs_$wakeup for ^a", cdte.name);
		end;
	     end;
	     return;

	end PROCESS_CDTE;

     end bump_procedure;

%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include answer_table;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dialup_values;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>answer_table

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the answer_table in SYSDIR.

   A:	$inform


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>whotab

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the whotab in SYSDIR.

   A:	$inform


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>installation_parms

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the installation_parms in SYSDIR.

   A:	$inform


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE  SYSDIR>cdt

   S:	$as1

   T:	In response to an operator command, COMMAND.

   M:	The system was unable to access the cdt in SYSDIR.

   A:	$inform


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE Incorrect number of arguments.

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Insufficient number of arguments supplied with the command.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: error: Usage: COMMAND (Person.Project|CHANNEL|mpx MPX|-pid) {TIME MESSAGE}

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Insufficient number of arguments supplied with the command.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE Invalid process id:
     PROCESS_ID.  Use the first 6 or all 12 digits of the pid.

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	The typed length of the PROCESS_ID was incorrect.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: error: No FNP tag specified

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Expected a FNP designator, but none typed following COMMAND.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: error: No multiplexer specified

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Expected a multiplexer designator, but none typed following COMMAND.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: error: Invalid FNP tag: FNP

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	The FNP tag following COMMAND was more than one character in length.
   FNP specifiers can only be one character long (ie: a, b, c, etc.).

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE Error recieved from AS.

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Recieved an error from answering service attempting to remove the
   terminal user from the system answer table.  User's process state will
   remain unchanged.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: ERROR_TABLE_MESSAGE From hcs_$wakeup for CHANNEL

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	Recieved an error from answering service when attempting to
   process the command COMMAND for channel CHANNEL.

   A:	$tryagain


   Message:
   operator_process_cmds_: COMMAND: error: Usage: COMMAND (Person.Project|CHANNEL|mpx MPX) {TIME MESSAGE}
   The "Person Project" format is obsolete.

   S:	$as1

   T:	In response to an operator command COMMAND.

   M:	The character "." was not found on the request line and COMMAND was
   not followed by a process id.  If argument following COMMAND is personid and
   projectid, the correct syntax is "Person.Project" not "Person Project".

   A:	$tryagain


   Message:
   operator_process_cmds_: unbump: error: invalid arguments

   S:	$as1

   T:	$response

   M:	A bad argument has been typed to
   the unbump command.
   No action was taken.

   A:	$tryagain


   Message:
   operator_process_cmds_: bump: error: invalid arguments

   S:	$as1

   T:	$response

   M:	A bad argument has been typed to
   the bump command.
   No action was taken.

   A:	$tryagain

   Message:
   operator_process_cmds_: detach: error: invalid arguments

   S:	$as1

   T:	$response

   M:	A bad argument has been typed to
   the detach command.
   No action was taken.

   A:	$tryagain


   Message:
   operator_process_cmds_: bump: no bump signalled to NAME PROJ

   S:	$as1

   T:	$response

   M:	An operator bump command specified a nonexistent channel
   name or user name and project.  No action was taken on the command.

   A:	Enter a corrected command line.  This message may be printed
   as a result of trying to bump a user by name when he has
   nobump privilege.  Bump him by channel name instead.


   Message:
   operator_process_cmds_: unbump: no unbump signalled to NAME PROJ

   S:	$as1

   T:	$response

   M:	An operator unbump command specified a nonexistent channel
   name or user name and project, or the user specified was not in a bumped
   state.  No action was taken on the command.

   A:	$tryagain


   Message:
   operator_process_cmds_: terminate: no terminate signalled to NAME PROJ

   S:	$as1

   T:	$response

   M:	An operator terminate command specified a nonexistent channel
   name or user name and project.  No action was taken on the command.

   A:	$tryagain


   Message:
   operator_process_cmds_: detach: no detach signalled to NAME PROJ

   S:	$as1

   T:	$response

   M:	An operator detach command specified a nonexistent channel
   name or user name and project.  No action was taken on the command.

   A:	$tryagain


   Message:
   operator_process_cmds_: detach: ERROR_MESSAGE CHANNEL

   S:	$as1

   T:	$response

   M:	The operator has issued a detach CHANNEL command and the error
   described by ERROR_MESSAGE occurred during the attempt to detach it.

   A:	$tryagain


   Message:
   operator_process_cmds_: detach: CHANNEL is in use by the message coordinator and can not be detached.

   S:	$as1

   T:	$response

   M:	An operator detach command specified a message coordinator channel.
   The channel was not detached.

   A:	Enter a corrected command line.  Use the drop command to
   take a channel away from the message coordinator.


   Message:
   operator_process_cmds_: detach: Channel CHANNEL is not currently active and cannot be detached.

   S:	$as1

   T:	$response

   M:	An operator detach command specified a channel that is not attached.
   No action was taken.

   A:	Enter a corrected command line


   Message:
   operator_process_cmds_: detach: NAME.PROJ detached

   S:	$as1

   T:	$response

   M:	This is the response to an operator detach command.
   The user affected is named.

   A:	$ignore


   Message:
   operator_process_cmds_: terminate: NAME.PROJ terminated

   S:	$as1

   T:	$response

   M:	This is the response to an operator terminate command.
   The user affected is named.

   A:	$ignore

   Message:
   operator_process_cmds_: bump: NAME.PROJ bumped

   S:	$as1

   T:	$response

   M:	This is the response to an operator bump command.
   The user affected is named.

   A:	$ignore

   Message:
   operator_process_cmds_: disconnect: NAME.PROJ disconnected.

   S:	$as1

   T:	$response

   M:	This is the response to an operator disconnect command.
   The user affected is named.

   A:	$ignore

   Message:
   operator_process_cmds_: unbump: NAME.PROJ unbumped

   S:	$as1

   T:	$response

   M:	This is the response to an operator unbump command.
   The user affected is named.

   A:	$ignore

   Message:
   operator_process_cmds_: bump: NAME.PROJ has "nobump"

   S:	$as1

   T:	$run

   M:	This is the response to the command bump NAME PROJ if
   the user has the nobump privilege.  The user was not
   bumped.

   A:	If it is imperative to bump the user, for instance at
   system shutdown time, do a who to find out his channel number,
   then type "bump CHANNEL".

   END MESSAGE DOCUMENTATION */

     end operator_process_cmds_;




		    send_ls_request_.pl1            08/04/87  1531.0rew 08/04/87  1221.9       44424



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-06-01,Coren), approve(87-07-13,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Initially written.
  2) change(87-03-10,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Corrected coding standard violations.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

send_ls_request_:
     procedure (P_ls_request_ptr, P_ls_request_lth, P_ls_ipc_reply_ptr,
	P_code);

/* Parameters */

dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  1 auto_event_wait_info aligned like event_wait_info automatic;
dcl  code		        fixed bin (35) automatic;
dcl  created_event_channel  bit (1) aligned automatic;
dcl  event_channel	        fixed bin (71) automatic;
dcl  ls_request_lth	        fixed bin (18) automatic;
dcl  request_ms_dirname     char (168) automatic;
dcl  request_ms_entryname   char (32) automatic;
dcl  server_event_channel   fixed bin (71) automatic;
dcl  server_process_id      bit (36) aligned automatic;

/* Entries */

dcl  hcs_$wakeup	        entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ipc_$block	        entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn     entry (fixed bin (71), fixed bin (35));
dcl  login_server_info_$request_info entry (bit (36) aligned, fixed bin (71),
		        char (*), char (*), fixed bin (35));
dcl  message_segment_$add_file entry (char (*), char (*), ptr, fixed bin, bit (72) aligned, fixed bin (35));

/* External */

dcl  error_table_$null_info_ptr fixed bin (35) ext static;
dcl  error_table_$smallarg  fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;

/* Constant */

dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);
dcl  FALSE	        bit (1) aligned initial ("0"b) internal static options (constant);


/* BUILTINS */

dcl (addr, currentsize, null, unspec)
		        builtin;


/* CONDITIONS */

dcl  cleanup	        condition;
%page;
/* Program */

	created_event_channel = FALSE;
	on cleanup
	     call Clean_Up ();

	ls_request_ptr = P_ls_request_ptr;
	ls_request_lth = P_ls_request_lth;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;

	if ls_request_ptr = null () then do;
	     code = error_table_$null_info_ptr;
	     goto RETURN;
	end;
	if ls_request_lth < currentsize (ls_request_header) then do;
	     code = error_table_$smallarg;
	     goto RETURN;
	end;

	if ls_request_header.header_version ^=
	     LS_REQUEST_HEADER_VERSION_1 then do;
	     code = error_table_$unimplemented_version;
	     goto RETURN;
	end;

	call login_server_info_$request_info (server_process_id,
	     server_event_channel, request_ms_dirname, request_ms_entryname,
	     code);
	if code ^= 0 then
	     goto RETURN;

	if ls_request_header.reply_event_channel = 0 then do;
	     created_event_channel = TRUE;
	     call ipc_$create_ev_chn (event_channel, code);
	     if code ^= 0 then
		goto RETURN;
	     ls_request_header.reply_event_channel = event_channel;
	end;

	call message_segment_$add_file (request_ms_dirname,
	     request_ms_entryname, ls_request_ptr, ls_request_lth * 36,
	     (""b), code);
	if code ^= 0 then
	     goto RETURN;

	call hcs_$wakeup (server_process_id, server_event_channel, -1, code);
	if code ^= 0 then
	     goto RETURN;

	event_wait_channel.n_channels = 1;
	event_wait_channel.pad = ""b;
	event_wait_channel.channel_id = ls_request_header.reply_event_channel;
	event_wait_info_ptr = addr (auto_event_wait_info);

BLOCK_AGAIN:
	call ipc_$block (addr (event_wait_channel),
	     event_wait_info_ptr, code);
	if code ^= 0 then
	     goto RETURN;

/**** For now, the formats are the same, but this might change.  Fill in the
      ipc reply output structure. */

	unspec (ls_reply_message) = unspec (event_wait_info.message);
	code = 0;
RETURN:
	P_code = code;
	return;
%page;
Clean_Up:
     procedure ();

	if created_event_channel then
	     call ipc_$delete_ev_chn (event_channel, (0));
	return;
     end Clean_Up;

/* format: off */
%page; %include event_wait_channel;
%page; %include event_wait_info;
%page; %include login_server_messages;

end send_ls_request_;



		    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
