



		    uc_cleanup_network_dials_.pl1   07/13/88  1113.4r w 07/13/88  0938.1       99216



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/****^  HISTORY COMMENTS:
  1) change(86-08-01,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-26,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use correct calling sequence when calling the force_disconnect
         entrypoint found in the connection list entry.
  3) change(87-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Changed for new uc_send_ls_response_ calling sequence.
  4) change(87-06-01,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Checked to get Login_Server handle out of ute.  The connection list
         entry contains only the Initializer handle.
  5) change(87-06-01,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Changed to get Login_Server's handle for a dialed connection out of
         the connection's user table entry (UTE).  The handle in the connection
         list is the Initializer's handle.
      B) Changed to logout/free the UTE if uc_send_ls_response_ cannot send
         the response to the Login_Server.
  6) change(87-06-09,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Include correct user process_group_id in
         login_server_termination_response.
  7) change(87-06-19,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Avoid reference through unset pointer by declaring ute_index
         automatic.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr,insnl */

uc_cleanup_network_dials_:
     procedure (P_process_id, P_logout_flag, P_code);

/* This procedure is called by the answering service when either 1) the
   process is destroyed (to cleanup any outstanding dialed connections),
   or 2) when the process (or the answering service) requests that all
   dialed connections be dropped.

   The "owner" (usually the login server) of the connection is notified
   so that it can perform the necessary processing (such as write an
   appropriate message on the user's terminal).

   This program searches the active_connection_list finding connections of
   which the specified proces is the user, and for each one that is a "dialed"
   connection, attempts to send a termination_response to the owner. If this
   fails, it attempts to force_disconnect the connection.
*/

/* Parameters */

dcl  P_process_id	        bit (36) aligned parameter;
dcl  P_logout_flag	        bit (1) aligned parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  1 auto_active_connection_info
		        aligned like active_connection_info automatic;
dcl  1 auto_ls_termination_response
		        aligned like login_server_termination_response automatic;
dcl  1 auto_ls_reply        aligned like ls_reply_message automatic;

dcl  code		        fixed bin (35) automatic;
dcl  connection_handle      fixed bin (35) automatic;
dcl  connection_name        char (32) automatic;
dcl  connection_offset      bit (18) automatic;
dcl  force_disconnect_name  char (64) automatic;
dcl  initializer_handle     bit (72) aligned automatic;
dcl  logout_flag	        bit (1) aligned automatic;
dcl  more		        bit (1) aligned automatic;
dcl  owner_process_id       bit (36) aligned automatic;
dcl  owner_handle	        bit (72) aligned automatic;
dcl  owner_event_channel    fixed bin (71) automatic;
dcl  send_terminate	        bit (1) aligned automatic;
dcl  user_group_id	        char (32) automatic;
dcl  user_process_id        bit (36) aligned automatic;
dcl  ute_index	        fixed bin automatic;
     

/* Entries */

dcl  hpriv_connection_list_$get_next_user
		        entry (bit (36) aligned, bit (18), ptr, fixed bin (35));
dcl  uc_logout_	        entry (ptr, char(*));
dcl  uc_send_ls_response_   entry (ptr, fixed bin(18), bit(36) aligned,
		        bit(72) aligned, fixed bin(71), ptr,
		        char(32) aligned, fixed bin(35), fixed bin(35));
dcl  user_table_mgr_$free   entry (ptr);


/* External */

dcl  error_table_$noentry   fixed bin (35) external static;

/* Builtins */

dcl  (addr, null, rtrim, size, unspec)
		        builtin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


/* Program */
	user_process_id = P_process_id;
	logout_flag = P_logout_flag;

/* Set up termination response -- we're going to send the same one to everybody */

	ls_response_ptr = addr (auto_ls_termination_response);
	unspec (login_server_termination_response) = ""b;
	login_server_response_header.message_type = LS_TERMINATION_RESPONSE;
	login_server_response_header.header_pad = ""b;
	login_server_response_header.version = LOGIN_SERVER_TERMINATION_RESPONSE_VERSION_1;

	login_server_termination_response.process_id = user_process_id;
	login_server_termination_response.status_code = 0;
	login_server_termination_response.logout = logout_flag;
						/* ? */

/* Now start searching the connection list. Each time we find a connection,
   we will get the next one before processing the current one, so that the
   current one doesn't get deleted before we can find the next.
*/

	active_connection_info_ptr = addr (auto_active_connection_info);
	unspec (active_connection_info) = ""b;
	active_connection_info.version = ACT_INFO_VERSION_1;

	connection_offset = ""b;			/* for finding the first one */
	more = Get_next (connection_offset);

	do while (more);

	     connection_offset = active_connection_info.offset;
	     if active_connection_info.usage_type = LS_DIAL_USAGE
						/* this is one we're interested in */
	     then do;				/* copy out info for later use */
		owner_process_id = active_connection_info.owner_process_id;
		owner_event_channel = active_connection_info.terminate_event_channel;
		initializer_handle = active_connection_info.owner_initializer_handle;
		connection_name = active_connection_info.connection_name;
		connection_handle = active_connection_info.connection_handle;
		force_disconnect_name = active_connection_info.force_disconnect_entry;
		ansp = as_data_$ansp;
		send_terminate = "0"b;
		do ute_index = 1 to anstbl.current_size;
		     utep = addr (anstbl.entry(ute_index));
		     if ute.active = NOW_LOGGED_IN &
			ute.tty_name = connection_name &
			ute.login_server_info.our_handle =
			initializer_handle &
			ute.login_server_info.process_id =
			owner_process_id then do;
			owner_handle = ute.login_server_info.his_handle;
			user_group_id = Get_Group_ID();
			send_terminate = "1"b;
		     end;
		end;
		if ^send_terminate then do;		/* connection not in ute. */
		     owner_process_id = ""b;		/* Make terminator do force_disconnect */
		     owner_handle = ""b;
		     user_group_id = "";
		     utep = null;
		     send_terminate = "1"b;
		end;
	     end;
	     else send_terminate = "0"b;

	     more = Get_next (connection_offset);

	     if send_terminate
	     then do;				/* now process the previous one */
		unspec(auto_ls_reply) = ""b;
		login_server_termination_response.process_group_id = 
		     user_group_id;
		call uc_send_ls_response_ (ls_response_ptr,
		     size (login_server_termination_response),
		     owner_process_id, owner_handle, owner_event_channel,
		     addr (auto_ls_reply),
		     active_connection_info.connection_name, 0, code);
		if code ^= 0 & utep ^= null then do;
		     call uc_logout_ (utep, "logout, dialed terminal");
		     call user_table_mgr_$free (utep);
		end;
	     end;
	end;

EXIT:
	P_code = code;
	return;

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


Get_Group_ID:
     procedure () returns (char(32) varying);

dcl  group	        char (32) varying;

          group = "";
	if ute.person ^= "" then do;
	     group = rtrim(ute.person);
	     group = group || ".";
	     group = group || rtrim(ute.project);
	     group = group || ".";
	     group = group || ute.tag;
	end;
	return (group);
     end Get_Group_ID;

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


Get_next:
     procedure (P_connection_offset) returns (bit (1) aligned);

dcl  P_connection_offset    bit (18) parameter;

dcl  connection_offset      bit (18);
dcl  code		        fixed bin (35);

	connection_offset = P_connection_offset;
	call hpriv_connection_list_$get_next_user (user_process_id, connection_offset, active_connection_info_ptr, code)
	     ;

	if code = error_table_$noentry		/* there are no more */
	then return ("0"b);
	else if code ^= 0
	then call Error (code);			/* nothing else should go wrong */
	else return ("1"b);

     end Get_next;

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


Error:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

	go to EXIT;
     end Error;

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


/* format: off */
 %include active_connection_info;
 %include answer_table;
 %include as_data_;
 %include dialup_values;
 %include login_server_messages;
 %include ls_usage_types;
 %include user_attributes;
 %include user_table_entry;
 %include user_table_header;

     end uc_cleanup_network_dials_;




		    uc_create_process_.pl1          07/13/88  1113.4rew 07/13/88  0906.6      157491



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,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-05-04,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Avoid referencing ute.ln_args if ute.arg_count = 0.
  4) change(87-05-09,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Set number_of_arguments to 0 when ute.arg_count = 0 to avoid unset
     variable.
  5) change(87-05-13,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Move act_ctl_$open_account call from uc_ls_create_request_ into here.
      B) Set pit.line_type from ute.line_type.
      C) Add code to undo steps of process creation when a fatal error occurs.
  6) change(87-05-31,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Assign ute.n_processes+1 to pit.n_processes when filling in the pit,
         since ute.n_processes hasn't been incremented for the new process at
         the point of that assignment. (dsa 227 228)
  7) change(88-02-02,Parisek), approve(88-02-11,MCR7849),
     audit(88-02-23,Lippard), install(88-07-13,MR12.2-1047):
     Added setting of new PIT elements min_ring & max_ring.  Eliminated PIT
     ringpad element. SCP6367
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_create_process_:
     procedure (P_utep, P_code);

/* Parameters */

dcl  P_utep	        ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  aip		        ptr automatic;
dcl  argp		        ptr automatic;
dcl  1 auto_create_info     structure aligned like create_info automatic;
dcl  code		        fixed bin (35) automatic;
dcl  ip		        ptr automatic;
dcl  length_of_arguments    fixed bin automatic;
dcl  length_of_pit	        fixed bin automatic;		/* size of fixed portion */
dcl  number_of_arguments    fixed bin automatic;
dcl  pdtep	        ptr automatic;
dcl  pit_size	        fixed bin automatic;		/* actual size */
dcl  reason	        char (8) aligned automatic;
dcl  satep	        ptr automatic;
dcl  whoptr	        ptr automatic;

/* Based */

dcl  based_arg_string       char (length_of_arguments) based aligned;
dcl  lengths	        (number_of_arguments) fixed bin based aligned;

/* Entries */

dcl  act_ctl_$close_account entry (ptr);
dcl  act_ctl_$cp	        entry (ptr);
dcl  act_ctl_$open_account  entry (ptr);
dcl  as_access_audit_$process entry (ptr, fixed bin, char (*));
dcl  convert_status_code_   entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  hcs_$truncate_seg      entry (ptr, fixed bin (19), fixed bin (35));
dcl  hphcs_$create_proc     entry (ptr, fixed bin (35));
dcl  ioa_$rsnnl	        entry () options (variable);
dcl  pdir_volume_manager_$select_pdir_volume entry (ptr, fixed bin (35));

/* External */

dcl  error_table_$out_of_sequence fixed bin (35) ext static;

/* Constant */

dcl  DEFAULT_CLS_SIZE       fixed bin (35) initial (65536) internal static options (constant);
dcl  DEFAULT_KST_SIZE       fixed bin initial (0) internal static options (constant);
dcl  DEFAULT_LOT_SIZE       fixed bin initial (512) internal static options (constant);
dcl  (FALSE	        initial ("0"b),
     TRUE		        initial ("1"b)) bit (1) aligned internal static options (constant);
dcl  ME		        char (18) initial ("uc_create_process_") internal static options (constant);

/* Builtins */

dcl  (addr, binary, bit, clock, divide, fixed, length, null, rel, rtrim, string,
     substr, unspec)        builtin;

%page;
/* Program */

	call Setup ();
	if ^ute.uflags.proc_create_ok then
	     call Abort (SL_LOG_SILENT, error_table_$out_of_sequence,
		"Called before process creation variables set for ^a.^a.^a.",
		ute.person, ute.project, ute.tag);

	call Setup_PIT ();
	call Setup_Create_Info ();
	call Select_Process_Directory_Volume ();
	call Create_Process ();

	call Update_Whotab ();
RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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 RETURN;

     end Abort;
%page;
Setup:
     procedure ();
	utep = P_utep;
	code = 0;

	ansp = as_data_$ansp;
	ip = as_data_$rs_ptrs (0);
	satep = ute.uprojp;
	pdtep = ute.pdtep;

	anstbl.current_time = clock ();
	return;
     end Setup;
%page;
Setup_PIT:
     procedure ();

dcl  i		        fixed bin automatic;

	pit_ptr = as_data_$pit_ptr;
	call hcs_$truncate_seg (pit_ptr, 0, code);
	if code ^= 0 then
	     call Abort (SL_LOG_BEEP, code, ME,
		"Truncate pit template failed; creating process for ^a.^a.^a.",
		ute.person, ute.project, ute.tag);

	pit.version = PIT_version_3;
	pit.process_type = ute.process_type;
	pit.login_responder = substr (ute.init_proc, 1, ute.ip_len);
	pit.homedir = ute.home_dir;
	pit.project = ute.project;
	pit.account = "";				/* unused */
	pit.n_processes = ute.n_processes + 1;		/* ute.n_processes hasn't been incremented yet. */
	pit.login_time = ute.login_time;
	pit.proc_creation_time = clock ();
	pit.old_proc_cpu = ute.cpu_usage;		/* will be zero for first process */
	pit.user_weight = ute.user_weight;
	pit.anonymous = ute.anonymous;
	pit.login_name = ute.person;
	pit.logout_pid = anstbl.as_procid;
	pit.logout_channel = ute.event;
	pit.group = ute.group;
	pit.min_ring = ute.lowest_ring;		/* minimum ring */
	pit.max_ring = ute.highest_ring;		/* maximum ring */

	string (pit.at) = string (ute.at);
	pit.whox = ute.whotabx;
	pit.outer_module = ute.outer_module;
	pit.dont_call_init_admin = ute.uflags.dont_call_init_admin;
	pit.terminal_access_class = ""b;		/* not used */
	pit.dollar_charge = user.dollar_charge;
	pit.dollar_limit = user.dollar_limit;
	pit.shift_limit (*) = user.shift_limit (*);
	pit.logins = user.logins;
	pit.crashes = user.crashes;
	pit.interactive (*) = user.interactive (*);
	pit.absentee (*) = user.absentee (*);
	pit.iod (*) = user.iod (*);
	pit.devices (*) = user.devices (*);
	pit.time_last_reset = user.time_last_reset;
	pit.absolute_limit = user.absolute_limit;
	pit.absolute_spent = user.absolute_spent;
	pit.absolute_cutoff = user.absolute_cutoff;
	pit.absolute_increm = user.absolute_increm;
	pit.rs_number = ute.rs_number;
	pit.request_id = ute.request_id;
	pit.authorization_range = ute.process_authorization_range;
/**** TBS: The charge_type is available in the cdte for MCS channels.  If
      this module ever supports MCS, it should be extracted from here. */
	pit.charge_type = 0;
	pit.term_type_name = ute.terminal_type;
	pit.line_type = ute.line_type;
/**** TBS: The tty_type is an obsolete field which is present in the cdte.
      If this module ever supports MCS, it should be extracted from here. */
	pit.tty_type = 0;
/**** TBS: If the value of pit.service is type is used, it will have to
      be conjured up from somewhere.  The cdte, of course, has this value
      for MCS channels.  It was probably only used for the old NCP/FTP. */
	pit.service_type = 0;
	pit.tty_answerback = ute.tty_id_code;
	pit.old_tty = "";
	pit.standby = ute.standby_line;
	pit.login_line = "";			/* unused */
	pit.cant_bump_until = ute.cant_bump_until;	/* 0 for abs & dmn */
	pit.input_seg = ute.input_seg;		/* only valid for absentees */
	pit.output_seg = ute.output_seg;		/* ditto */
	pit.max_cpu_time = ute.max_cpu_time;		/* ditto */
	if ute.process_type = PT_ABSENTEE then
	     pit.abs_queue = ute.queue;
	else pit.abs_queue = -1;
	string (pit.abs_attributes) = "0"b;		/* copy ute abs_attributes bits */
	pit.restartable = ute.restartable;
	pit.user_deferred_until_time = ute.user_deferred_until_time;
	pit.proxy = ute.proxy;
	pit.set_bit_cnt = ute.set_bit_cnt;
	pit.truncate_absout = ute.truncate_absout;
	pit.restarted = ute.restarted;

	aip = addr (pit.start_arg_info);
	pit.arg_info_ptr = fixed (rel (aip));

	pit.old_proc_core = ute.mem_usage;
	pit.old_proc_io_ops = 0;
	pit.tty = ute.tty_name;
	if length (rtrim (pit.tty)) <= length (pit.old_tty) then
	     pit.old_tty = substr (pit.tty, 1, length (pit.old_tty));

	number_of_arguments = ute.arg_count;
	aip -> arg_info.arg_count = number_of_arguments;
	if number_of_arguments > 0 then do;
	     length_of_arguments = ute.ln_args;
	     aip -> arg_info.ln_args = length_of_arguments;
	     argp = ute.arg_lengths_ptr;
	     do i = 1 to number_of_arguments;
		aip -> arg_info.arg_lengths (i) = argp -> lengths (i);
	     end;
	     if length_of_arguments > 0 then do;
		argp = ute.args_ptr;
		aip -> arg_info.args = argp -> based_arg_string;
	     end;
	end;
	else length_of_arguments, aip -> arg_info.ln_args = 0;

	length_of_pit = binary (rel (addr (pit.start_arg_info)), 18);
	pit_size = length_of_pit + number_of_arguments +
	     divide (length_of_arguments + 3, 4, 35, 0) + 2;
	return;

     end Setup_PIT;
%page;
Setup_Create_Info:
     procedure ();


	if anstbl.processid_index > 262140 | anstbl.processid_index < 0 then
	     anstbl.processid_index = 0;
	anstbl.processid_index = anstbl.processid_index + 1;

	auto_create_info.processid.rel_apte = ""b;	/* returned from hardcore */
	auto_create_info.processid.unique_index =
	     bit (fixed (anstbl.processid_index, 18), 18);
	auto_create_info.version = version_of_create_info;
	auto_create_info.term_channel = pit.logout_channel;
	auto_create_info.term_processid = pit.logout_pid;
	auto_create_info.words_of_pit = pit_size;

	if ute.pdir_quota > 0 then			/* nonzero value in PDT of SAT */
	     auto_create_info.record_quota = ute.pdir_quota;
	else do;
	     ute.pdir_quota = installation_parms.default_pdir_seg_quota;
	     auto_create_info.record_quota = ute.pdir_quota;
	end;
	auto_create_info.ppml = 0;			/* obsolete */
	auto_create_info.initial_ring = ute.initial_ring;
	auto_create_info.highest_ring = ute.highest_ring;

	auto_create_info.timax = -1;			/* but see below */
	if ute.process_type = PT_ABSENTEE then
	     if ute.queue > 0 then
		auto_create_info.timax =
		     installation_parms.abs_timax (ute.queue);
	auto_create_info.account_ptr = null ();		/* unused */
	auto_create_info.pit_ptr = pit_ptr;

	call ioa_$rsnnl ("^[anonymous^s^;^a^].^a.^a",
	     auto_create_info.process_group_id, (0),
	     (ute.anonymous = 1), ute.person, ute.project, ute.tag);

	auto_create_info.user_processid = "";		/* unused */
	auto_create_info.account_id = "";		/* unused */
	auto_create_info.homedir = rel (addr (pit.homedir));

	auto_create_info.lot_in_stack = TRUE;
	if ute.lot_size = 0 then
	     auto_create_info.lot_size = DEFAULT_LOT_SIZE;
	else if ute.lot_size > 0 then
	     auto_create_info.lot_size = ute.lot_size;
	else do;
	     auto_create_info.lot_size = -(ute.lot_size);
	     auto_create_info.lot_in_stack = FALSE;
	end;

	auto_create_info.cls_in_stack = FALSE;
	if ute.cls_size = 0 then
	     auto_create_info.cls_size = DEFAULT_CLS_SIZE;
	else if ute.cls_size > 0 then
	     auto_create_info.cls_size = ute.cls_size;
	else do;
	     auto_create_info.cls_size = -(ute.cls_size);
	     auto_create_info.cls_in_stack = TRUE;
	end;

	if ute.kst_size = 0 then
	     auto_create_info.kst_size = DEFAULT_KST_SIZE;
	else auto_create_info.kst_size = ute.kst_size;

	auto_create_info.dont_call_init_admin = ute.uflags.dont_call_init_admin;
	auto_create_info.audit = ute.audit;
	auto_create_info.process_authorization = ute.process_authorization;
	auto_create_info.max_process_authorization =
	     ute.process_authorization_range (2);
	auto_create_info.work_class = ute.work_class;
	auto_create_info.subsystem = substr (ute.init_proc, ute.ip_len + 1,
	     ute.ss_len);

	ute.pdir_dir_quota = installation_parms.default_pdir_dir_quota;
	auto_create_info.dir_quota = ute.pdir_dir_quota;
	return;
     end Setup_Create_Info;
%page;
Select_Process_Directory_Volume:
     procedure ();

/**** Chose a process directory logical volume for this process */

	if ^as_data_$debug_flag then do;
	     call pdir_volume_manager_$select_pdir_volume (utep, code);
	     if code ^= 0 then
		call Log_Error_with_Code (SL_LOG_BEEP, code, ME,
		     "Assigning pdir volume for ^a.^a.^a",
		     ute.person, ute.project, ute.tag);
	end;
	return;
     end Select_Process_Directory_Volume;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error_with_Code: log an error via sys_log_$general and continue       */
/* execution.						       */
/*							       */
/* Syntax:  call Log_Error_with_Code (severity, code, ioa_ctl, args);	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Log_Error_with_Code:
     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));

     end Log_Error_with_Code;
%page;
Create_Process:
     procedure ();

	ute.n_processes = ute.n_processes + 1;
	if ute.n_processes = 1 then			/* not new proc? */
	     call act_ctl_$open_account (utep);

	call hphcs_$create_proc (addr (auto_create_info), code);
	if code ^= 0 then do;
	     ute.active = NOW_LOGGED_IN;
	     ute.uflags.proc_create_ok = FALSE;
	     call convert_status_code_ (code, reason, "");
	     call as_access_audit_$process (utep, -AS_AUDIT_PROCESS_CREATE,
		(reason));
	     call act_ctl_$close_account (utep);
	     call Abort (SL_LOG, code, ME,
		"Could not create process for ^a.^a.^a.",
		ute.person, ute.project, ute.tag);
	end;

	ute.proc_id = unspec (auto_create_info.processid);
	ute.active = NOW_HAS_PROCESS;
	ute.destroy_flag = WAIT_LOGOUT_SIG;
	call as_access_audit_$process (utep, AS_AUDIT_PROCESS_CREATE, "");
	call act_ctl_$cp (utep);
	return;
     end Create_Process;
%page;
Update_Whotab:
     procedure ();

/**** Various items in the whotab entry for the user were not filled in at
      login time because the values were not known.  They are updated now. */

dcl  whotab_idx	        fixed bin automatic;

	whoptr = as_data_$whoptr;

/**** Update the number of load control units in the whotab header */

	whotab.n_units = whotab.n_units + ute.user_weight;

/**** Update the per-user whotab values if the user has a whotab entry */

	if ute.whotabx ^= 0 then do;			/* user has a whotab entry */
	     whotab_idx = ute.whotabx;
	     whotab.e (whotab_idx).units = ute.user_weight;
	     whotab.e (whotab_idx).stby = ute.standby_line;
	     whotab.e (whotab_idx).group = ute.group;
	     whotab.e (whotab_idx).cant_bump_until = ute.cant_bump_until;
	end;
	return;
     end Update_Whotab;
						/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include access_audit_bin_header; /* needed by PL/I */
%page; %include as_audit_structures;
%page; %include create_info;
%page; %include dialup_values;
%page; %include installation_parms;
%page; %include pdt;

dcl  pdtp		        ptr automatic init (null);	/* pdt needs it */
%page; %include pit;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

end uc_create_process_;




		    uc_create_process_check_.pl1    07/13/88  1113.4rew 07/13/88  0904.2      151443



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1.
      B) Move notification of other processes into uc_login_, now that the
         login operation is distinguished from process creation.
      C) Add support for minimum MNA terminal manager ring check.  Data comes
         from login_server_process_request.minimum_ring.
  3) change(87-05-09,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Corrected to reference login_server_process_request.default_io_module,
     rather than .outer_module.  login_server_process_request.outer_module was
     assign to ute.outer_mode in uc_ls_create_request_.
  4) change(88-02-02,Parisek), approve(88-02-11,MCR7849),
     audit(88-03-22,Lippard), install(88-07-13,MR12.2-1047):
     Added setting of new UTE element lowest_ring. SCP6367
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_create_process_check_:
     procedure (P_utep, P_ls_process_request_ptr, P_code);

/* Parameters */

dcl  P_ls_process_request_ptr ptr parameter;		/* ptr to process request data structure */
dcl  P_utep	        ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  pdtep	        ptr automatic;
dcl  satp		        ptr automatic;
dcl  satep	        ptr automatic;

/* Entries */

dcl  act_ctl_$check_for_process_creation entry (ptr, char (8) aligned, char (168) var, fixed bin (35));
dcl  load_ctl_$check_for_process_creation entry (ptr, fixed bin (35));

/* External */

dcl  as_error_table_$illegal_om_arg fixed bin (35) external static;
dcl  as_error_table_$already_logged_in fixed bin (35) external static;
dcl  as_error_table_$illegal_hd_arg fixed bin (35) external static;
dcl  as_error_table_$illegal_ip_arg fixed bin (35) external static;
dcl  as_error_table_$illegal_ss_arg fixed bin (35) external static;
dcl  as_error_table_$long_ip_arg fixed bin (35) external static;
dcl  as_error_table_$long_ss_arg fixed bin (35) external static;
dcl  as_error_table_$no_primary fixed bin (35) ext static;
dcl  as_error_table_$ring_too_high fixed bin (35) external static;
dcl  as_error_table_$ring_too_low fixed bin (35) external static;
dcl  as_error_table_$user_fg_cpu_limit fixed bin (35) ext static;
dcl  as_error_table_$user_max_bg fixed bin (35) ext static;
dcl  as_error_table_$user_max_fg fixed bin (35) ext static;
dcl  error_table_$bad_arg   fixed bin (35) ext static;
dcl  error_table_$out_of_sequence fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (24) int static options (constant) init ("uc_create_process_check_");
dcl  (TRUE	        initial ("1"b),
     FALSE	        initial ("0"b)) bit (1) aligned internal static options (constant);

/* Builtin */

dcl  (addr, clock, index, length, max, min, null, rtrim, substr)
		        builtin;
%page;
/* Program */

	call Setup ();
	if ute.active ^= NOW_LOGGED_IN then
	     call Abort_Create (error_table_$out_of_sequence);

	call Check_Process_Limits ();
	call Check_For_Multiple_Logins ();
	call Check_With_Accounting ();
	call Setup_Initial_Procedure_And_Subsystem ();
	call Setup_Login_Ring ();
	call Setup_Outer_Module ();
	call Setup_Miscellaneous_Variables ();
	call Check_With_Load_Control ();

	ute.uflags.proc_create_ok = TRUE;
RETURN:
	P_code = code;
	return;
%page;
Setup:
     procedure ();

	utep = P_utep;
	ls_request_ptr = P_ls_process_request_ptr;
	code = 0;

	ansp = as_data_$ansp;
	satp = as_data_$satp;
	satep = ute.uprojp;
	pdtep = ute.pdtep;

	anstbl.current_time = clock ();
	return;
     end Setup;
%page;
Abort_Create:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

	code = P_code;
	goto RETURN;
     end Abort_Create;
%page;
Check_Process_Limits:
     procedure ();

dcl  limit	        fixed bin automatic;

	if ute.queue <= 0 then do;			/* foreground process */
	     if ute.process_type = PT_ABSENTEE then do;

/**** Check foreground absentee CPU limits */
		limit = project.abs_foreground_cpu_limit;
		if limit = 0 then			/* no SAT limit */
		     limit = user.abs_foreground_cpu_limit;
		else if user.abs_foreground_cpu_limit > 0 then /* PDT limit */
		     limit = min (limit, user.abs_foreground_cpu_limit);

		if limit > 0 then			/* there is a SAT or PDT limit */
		     if ute.max_cpu_time > limit then
			call Abort_Create (as_error_table_$user_fg_cpu_limit);
		if ^ute.at.pm_ok &			/* primary not allowed */
		     ^ute.uflags.foreground_secondary_ok/* secondary not ok */
		then call Abort_Create (as_error_table_$no_primary);
	     end;

/**** Check foreground absentee process limits */

	     limit = project.max_foreground;
	     if limit = 0 then			/* no SAT limit */
		limit = user.max_foreground;		/* use PDT limit */
	     else if user.max_foreground > 0 then	/* there is a PDT limit */
		limit = min (limit, user.max_foreground);
	     if limit > 0 then			/* there is a limit */
		if user.n_foreground ^< limit then do;	/* user at limit */
		     if ute.process_type = PT_INTERACTIVE then do;
			if user.n_interactive > 0 &	/* already has one */
			     ^ute.at.multip then do;	/* no multip */
			     call Abort_Create (as_error_table_$already_logged_in);
			end;			/* end already has one */
		     end;				/* end interactive */
		     else				/* foreground absentee */
			call Abort_Create (as_error_table_$user_max_fg);
		end;				/* user at limit */
	end;					/* foreground process */
	else do;					/* background process */
	     if ^ute.abs_run then do;			/* not force-run by operator */
		limit = project.max_background;
		if limit = 0 then			/* no SAT limit */
		     limit = user.max_background;	/* pick up PDT limit */
		else if user.max_background > 0 then	/* there is a PDT limit */
		     limit = min (limit, user.max_background); /* get smaller */
		if limit > 0 then			/* if there is a limit */
		     if user.n_background ^< limit then /* user at limit */
			call Abort_Create (as_error_table_$user_max_bg);
	     end;					/* end not force-run by operator */
	end;					/* end background process */
	return;
%page;

     end Check_Process_Limits;
%page;
Check_For_Multiple_Logins:
     procedure ();

	if ute.process_type ^= PT_INTERACTIVE | ute.anonymous = 1 then
	     return;

	if user.n_interactive > 0 then do;
	     if ^ute.at.multip then			/* no multip */
		call Abort_Create (as_error_table_$already_logged_in);
	end;
	return;
     end Check_For_Multiple_Logins;
%page;
Check_With_Accounting:
     procedure ();

dcl  short_info	        char (8) aligned automatic;
dcl  long_info	        char (168) varying automatic;

	call act_ctl_$check_for_process_creation (utep, short_info, long_info, code);
	if code ^= 0 then
	     call Abort_Create (code);
	return;
     end Check_With_Accounting;
%page;
Setup_Initial_Procedure_And_Subsystem:
     procedure ();

dcl  ip_len	        fixed bin automatic;
dcl  ss_len	        fixed bin automatic;
dcl  subsystem	        char (64) automatic;

/**** Check if login is restricted to using a special process overseer.
      If it is, use this correct overseer_. */

	if ute.network_connection_type ^= 0 &
	     ute.network_connection_type ^= NETWORK_CONNECTION_LOGIN then do;
	     if ute.network_connection_type ^=
		NETWORK_CONNECTION_DSA_FILE_TRANSFER then
		call Abort_Create (error_table_$bad_arg);
	     else do;				/* DSA file transfer connection */
		ute.init_proc = "dsa_uft_server_overseer_";
		ute.ip_len = length (rtrim (ute.init_proc));
		ute.ss_len = 0;			/* no subsystem */
		ute.uflags.dont_call_init_admin = FALSE;
	     end;
	end;
	else do;					/* Normal LOGIN  */
/**** Save the subsystem so that we don't clobber it below */

	     if ute.uflags.ss_given then
		subsystem = substr (ute.init_proc, ute.ip_len + 1, ute.ss_len);

	     if ute.uflags.ip_given then do;
		if ^ute.at.vinitproc then
		     call Abort_Create (as_error_table_$illegal_ip_arg);
	     end;
	     else do;				/* not supplied on command line, use PDT */
		if user.uflags.ip_given then		/* length stored in PDT */
		     ip_len = user.ip_len;
		else do;				/* must scan and figure it out */
		     ip_len = -1 + index (user.initial_procedure, " ");
		     if ip_len = -1 then		/* if no blanks, then */
			ip_len = length (user.initial_procedure);
		end;				/* it is 64 characters long */

		substr (ute.init_proc, 1, ip_len) =
		     substr (user.initial_procedure, 1, ip_len);
		ute.ip_len = ip_len;
		ute.uflags.dont_call_init_admin = user.uflags.dont_call_init_admin;
	     end;

	     if ute.ip_len > length (",direct") then
		if substr (ute.init_proc,
		     ute.ip_len - length (",direct") + 1,
		     length (",direct")) = ",direct" then do;
		     ute.uflags.dont_call_init_admin = TRUE;
		     ute.ip_len = ute.ip_len - length (",direct");
		end;

/**** Now process the subsystem.  We may have it already from above */

	     if ute.uflags.ss_given then do;
		if ^ute.at.vinitproc then
		     call Abort_Create (as_error_table_$illegal_ss_arg);
		ss_len = ute.ss_len;
	     end;
	     else
		if user.uflags.ss_given then do;	/* is it supplied in PDT? */
		ss_len = user.ss_len;
		subsystem = substr (user.initial_procedure, user.ip_len + 1,
		     user.ss_len);
	     end;
	     else ss_len = -1;			/* not supplied at all */

	     if ss_len ^= -1 then do;			/* we have a subsystem */
		if ss_len + ute.ip_len > length (ute.init_proc) then do;
						/* no room */
		     if ute.uflags.ip_given then
			call Abort_Create (as_error_table_$long_ip_arg);
		     else call Abort_Create (as_error_table_$long_ss_arg);
		end;
		else do;
		     substr (ute.init_proc, ute.ip_len + 1, ss_len) =
			substr (subsystem, 1, ss_len);
		     ute.ss_len = ss_len;
		     ute.uflags.ss_given = TRUE;
		end;
	     end;
	end;
	return;
     end Setup_Initial_Procedure_And_Subsystem;
%page;
Setup_Login_Ring:
     procedure ();

dcl  ring		        fixed bin (3) automatic;

	if user.low_ring < project.min_ring then
	     call Log ("Raised min ring for ^a.^a from ^d (in PDTE) to ^d (in SATE).",
		ute.person, ute.project, user.low_ring, project.min_ring);

	if ute.initial_ring ^= -1 then		/* user specified it */
	     ring = ute.initial_ring;
	else ring = user.default_ring;		/* otherwise use PDT default */

	ring = max (project.min_ring, user.low_ring, ring);
	if ring <= 0 then
	     ring = as_data_$dft_user_ring;

	if login_server_process_request.minimum_ring_given then do;
	     if ring < login_server_process_request.minimum_ring then do;
		call Log ("Raised min ring for ^a.^a from ^d (in SATE/PDTE) to ^d (of Login Server)",
		     ute.person, ute.project, ring,
		     login_server_process_request.minimum_ring);
		ring = login_server_process_request.minimum_ring;
	     end;
	end;

	if ute.initial_ring ^= -1 then
	     if ute.initial_ring < ring then
		call Abort_Create (as_error_table_$ring_too_low);

	if ring > as_data_$max_user_ring then
	     ring = as_data_$max_user_ring;

	ute.lowest_ring = max (project.min_ring, user.low_ring);
	ute.initial_ring = ring;

/**** Determine max user ring */

	if user.high_ring > project.max_ring then
	     call Log ("Lowered max ring for ^a.^a from ^d (in PDTE) to ^d (in SATE).",
		ute.person, ute.project, user.high_ring, project.max_ring);

	if project.max_ring <= 0 then
	     ring = as_data_$dft_user_ring + 1;
	else ring = project.max_ring;

	ring = min (ring, user.high_ring, as_data_$max_user_ring);

	if ring < ute.initial_ring then
	     call Abort_Create (as_error_table_$ring_too_high);

	ute.highest_ring = ring;

	return;
     end Setup_Login_Ring;
%page;
Setup_Outer_Module:
     procedure ();

	if ute.outer_module ^= "" then
	     if ^ute.at.vinitproc then
		call Abort_Create (as_error_table_$illegal_om_arg);

	if ute.outer_module = "" then do;
	     ute.outer_module = user.outer_module;
	     if ute.outer_module = "" |
		ute.outer_module = as_data_$tty_dim then do;

		if login_server_process_request.default_io_module ^= "" then
		     ute.outer_module =
			login_server_process_request.default_io_module;
		else
		     ute.outer_module = as_data_$tty_dim;
	     end;
	end;
	return;
     end Setup_Outer_Module;
%page;
Setup_Miscellaneous_Variables:
     procedure ();

dcl  i		        fixed bin automatic;

/**** Constraint process directory quota */

	if project.pdir_quota > 0 then do;		/* there is a SAT limit */
	     if user.pdir_quota > project.pdir_quota then
		call Log ("Reduced pdir quota for ^a.^a from ^d (in PDTE) to ^d (in SATE).",
		     ute.person, ute.project, user.pdir_quota,
		     project.pdir_quota);
	     ute.pdir_quota = min (project.pdir_quota, user.pdir_quota);
	end;
	else					/* no SAT limit */
	     ute.pdir_quota = user.pdir_quota;

/**** Copy various tables sizes from the PDT */

	ute.lot_size = user.lot_size;
	ute.kst_size = user.kst_size;
	ute.cls_size = user.cls_size;

/**** Determine user's load control weight */

	ute.user_weight = -1;			/* not yet set */
	do i = 1 to sat.uwt_size while (ute.user_weight = -1);
	     if ute.init_proc = sat.uwt (i).initproc then
		ute.user_weight = sat.uwt (i).units;
	end;
	if ute.user_weight = -1 then
	     ute.user_weight = as_data_$default_weight;

/**** Locate user's home directory */

	if ute.home_dir ^= "" then			/* user supplied home directory? */
	     if ^ute.at.vhomedir then			/* allowed */
		call Abort_Create (as_error_table_$illegal_hd_arg);
	     else ;
	else ute.home_dir = user.home_dir;		/* use PDT default */

/**** Process disconnection/saving checks. */

	if ute.process_type = PT_INTERACTIVE then do;	/* only for interactive processes */
	     if ute.at.save_on_disconnect & ute.at.disconnect_ok then
		ute.uflags.save_if_disconnected = TRUE;
	     else ute.uflags.save_if_disconnected = FALSE;
	end;
	return;
     end Setup_Miscellaneous_Variables;
%page;
Check_With_Load_Control:
     procedure ();

	call load_ctl_$check_for_process_creation (utep, code);
	if code ^= 0 then
	     call Abort_Create (code);
	return;
     end Check_With_Load_Control;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log:  log information about process creation restrictions in AS log.      */
/*							       */
/* Syntax:  call Log (ioa_ctl, args);				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Log:
     procedure () options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_msg;
	sl_info.caller = ME;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));

     end Log;

/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include dialup_values;
%page; %include login_server_messages;
%page; %include pdt;

dcl  pdtp		        ptr automatic init (null);	/* pdt needs it  */
%page; %include sat;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

     end uc_create_process_check_;




		    uc_dial_.pl1                    07/13/88  1113.4r w 07/13/88  0938.1      107631



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,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-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations.
      B) Standardize format of audit messages.
  4) change(87-06-01,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Expand aliases in "dial DIAL_ID person.project".
  5) change(87-06-11,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Change to call as_access_audit_$channel to audit dialins.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr,insnl */

uc_dial_:
     procedure (P_utep, P_dial_qualifier, P_person_id, P_project_id,
	P_connection_name, P_connection_access_class_range, P_target_utep,
	P_code);

/* Parameters */

dcl  P_utep	        ptr parameter;
dcl  P_dial_qualifier       char (*) parameter;
dcl  P_person_id	        char (*) parameter;
dcl  P_project_id	        char (*) parameter;
dcl  P_connection_name      char (*) parameter;
dcl  P_connection_access_class_range
		        (2) bit (72) aligned parameter;
dcl  P_target_utep	        ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  1 auto_channel_audit_info
		        aligned like channel_audit_info automatic;
dcl  code		        fixed bin (35) automatic;
dcl  dial_qualifier	        char (32) automatic;
dcl  find_person_project    bit (1) aligned automatic;
dcl  target_person_id       char (32) automatic;
dcl  target_project_id      char (32) automatic;
dcl  target_utep	        ptr automatic;
dcl  user_validated	        bit (1) aligned automatic;

/* Based */

dcl  1 target_ute	        aligned like ute based (target_utep);


/* Entries */

dcl  aim_check_$in_range    entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl  as_access_audit_$channel
		        entry (ptr, ptr, ptr, fixed bin, ptr, char(*));
dcl  convert_status_code_   entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  hash_$search	        entry (ptr, char (*), fixed bin (35), fixed bin (35));
dcl  pnt_manager_$admin_get_entry
		        entry (char (*), ptr, fixed bin (35));


/* External */

dcl  (
     as_error_table_$dialnoline,
     as_error_table_$dialnotup,
     error_table_$action_not_performed,
     error_table_$ai_restricted,
     error_table_$id_not_found
     )		        fixed bin (35) ext static;

/* Constant */

dcl  DENIED	        bit (1) aligned initial ("0"b) internal static options (constant);
dcl  FALSE	        bit (1) aligned initial ("0"b) internal static options (constant);
dcl  GRANTED	        bit (1) aligned initial ("1"b) internal static options (constant);
dcl  ME		        char (8) initial ("uc_dial_") int static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtin */

dcl  (addr, length, null, rtrim, substr)
		        builtin;
%page;
/* Program */

	code = 0;
	utep = P_utep;
	if utep = null ()
	then
	     user_validated = FALSE;
	else user_validated = TRUE;

	ansp = as_data_$ansp;
	dutp = as_data_$dutp;
	autp = as_data_$autp;

	dial_qualifier = P_dial_qualifier;
	if dial_qualifier = ""
	then
	     call Abort (as_error_table_$dialnoline);

	if dial_qualifier = "system"
	then
	     call Abort (error_table_$action_not_performed);

	target_person_id = P_person_id;
	target_project_id = P_project_id;
	if target_person_id = ""
	then
	     find_person_project = FALSE;
	else do;
	     find_person_project = TRUE;
	     if ^convert_aliases (target_person_id, target_project_id)
	     then call Abort (as_error_table_$dialnotup);
	end;

	target_utep = find_dialable_process ();
	if target_utep = null ()
	then
	     call Abort (as_error_table_$dialnotup);

/**** Mark the UTE has having a client */
	target_ute.ndialed_consoles =
	     target_ute.ndialed_consoles + 1;

/**** Audit the DIALIN */

	call Audit_dialin (target_utep, GRANTED, "");

	code = 0;

RETURN:
	if code = 0
	then
	     P_target_utep = target_utep;
	else P_target_utep = null ();

	P_code = code;
	return;
%page;
convert_aliases:
     procedure (rq_person, rq_project) returns (bit (1));

dcl  rq_person	        char (32);
dcl  rq_project	        char (32);

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 Log_Error (code,
		"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 = pnte.default_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 Log_Error (-1,
			"^a: sat.ht has ""^a"", sat has ""^a"" at ^p", rq_project,
			project.project_id, satep);
		     return (FALSE);
		end;
	     rq_project = project.project_id;
	end;

	return (TRUE);
     end convert_aliases;
%page;
find_dialable_process:
     procedure () returns (ptr);

dcl  i		        fixed bin automatic;
dcl  temp_utep	        ptr automatic;

	do i = 1 to anstbl.current_size;
	     temp_utep = addr (anstbl.entry (i));
	     if ok_for_dial (temp_utep)
	     then
		return (temp_utep);
	end;

	do i = 1 to dutbl.current_size;
	     temp_utep = addr (dutbl.entry (i));
	     if ok_for_dial (temp_utep)
	     then
		return (temp_utep);
	end;

	do i = 1 to autbl.current_size;
	     temp_utep = addr (autbl.entry (i));
	     if ok_for_dial (temp_utep)
	     then
		return (temp_utep);
	end;

	return (null ());				/* couldn't find any dialable process */
%page;
ok_for_dial:
	procedure (P_utep) returns (bit (1) aligned);

dcl  P_utep	        ptr parameter;

	     if P_utep -> ute.active ^= NOW_HAS_PROCESS
	     then
		return (FALSE);
	     if find_person_project
	     then
		do;
		if P_utep -> ute.person ^= target_person_id
		then
		     return (FALSE);
		if P_utep -> ute.project ^= target_project_id
		then
		     return (FALSE);
	     end;
	     else do;				/* we want a registered dial server */
		if ^P_utep -> ute.registered_dial_server
		then
		     return (FALSE);
	     end;

	     if P_utep -> ute.dial_qualifier ^= dial_qualifier
	     then
		return (FALSE);
	     if ^P_utep -> ute.at.dialok
	     then
		return (FALSE);
	     if P_utep -> ute.dial_ev_chn = 0
	     then
		return (FALSE);

/**** Now perform access checks (these should be done first) */
	     if ^aim_check_$in_range (P_utep -> ute.process_authorization,
		P_connection_access_class_range)
	     then
		do;
		code = error_table_$ai_restricted;
		call Audit_denied_dialin (P_utep, code);
		return (FALSE);
	     end;

/**** TBS: We should perform discretionary access control checks too. */
	     return (TRUE);
	end ok_for_dial;

     end find_dialable_process;
%page;
Abort:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

	code = P_code;
	goto RETURN;

     end Abort;
%page;
Audit_denied_dialin:
     procedure (P_utep, P_code);

dcl  P_utep	        pointer parameter;
dcl  P_code	        fixed bin (35) parameter;
dcl  reason	        char (100) aligned automatic;

	if P_code = 0
	then
	     reason = "";
	else
	     call convert_status_code_ (P_code, (""), reason);

	call Audit_dialin (P_utep, DENIED, rtrim(reason));
	return;

     end Audit_denied_dialin;
%page;
Audit_dialin:
     procedure (P_target_utep, grant_sw, reason);
     
dcl  P_target_utep	        ptr parameter;
dcl  grant_sw	        bit(1) aligned parameter;
dcl  reason	        char(*) parameter;

dcl  action	        fixed bin(17) automatic;
dcl  target_utep	        ptr automatic;
dcl  1 target_ute	        aligned like ute based (target_utep);

	target_utep = P_target_utep;

	channel_audit_info_ptr = addr(auto_channel_audit_info);
	channel_audit_info.channel_name = P_connection_name;
	channel_audit_info.valid = FALSE;
	channel_audit_info.valid.service_info = TRUE;
	channel_audit_info.valid.user_validation_level = TRUE;
	channel_audit_info.valid.access_class = TRUE;
	channel_audit_info.valid.access_class_range = TRUE;
	channel_audit_info.service_info = dial_qualifier;
	channel_audit_info.user_validation_level = target_ute.initial_ring;
	channel_audit_info.access_class = target_ute.process_authorization;
	channel_audit_info.access_class_range =
	   P_connection_access_class_range;

	action = AS_AUDIT_CHANNEL_DIALIN;
	if ^grant_sw then action = -action;

	call as_access_audit_$channel (null, utep, target_utep,
	   action, addr(channel_audit_info), reason);

     end Audit_dialin;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error:  Report errors via sys_log_$general.		       */
/*							       */
/* 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_BEEP;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	return;

     end Log_Error;


/* format: off */
%page; %include absentee_user_table;
%page; %include access_audit_bin_header;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_audit_structures;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include pnt_entry;

dcl  1 pnte	        structure aligned like pnt_entry;
%page; %include sat;

dcl  satep	        ptr;
dcl  satp		        ptr;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

     end uc_dial_;




		    uc_list_disconnected_procs_.pl1 07/13/88  1113.4r w 07/13/88  0938.2       73593



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,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-05-16,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add cleanup handler.
      B) Convert to sys_log_$general.
  4) change(87-05-20,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct problem which damaged ute.ute_index.
  5) change(87-07-29,GDixon), approve(87-07-29,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correctly handle case where number of disconnected processes exceeds
         user.n_disconnected.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_list_disconnected_procs_:
     procedure (P_utep, P_area_ptr, P_uc_disconnected_process_list_ptr);

/* Parameters */

dcl  P_utep	        ptr parameter;
dcl  P_area_ptr	        ptr parameter;
dcl  P_uc_disconnected_process_list_ptr ptr parameter;

/* Automatic */

dcl  area_ptr	        ptr automatic;
dcl  code		        fixed bin (35) automatic;
dcl  processes_found        fixed bin automatic;
dcl  temp_list	        ptr automatic;
dcl  temp_utep	        ptr automatic;
dcl  ute_index	        fixed bin;

/* Based */

dcl  system_area	        area based (area_ptr);

/* Entries */

dcl  get_system_free_area_  entry () returns (ptr);

/* External */

dcl  error_table_$null_info_ptr fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (27) initial ("uc_list_disconnected_procs_") internal static options (constant);

/* Builtins */

dcl  (addr, null)	        builtin;


/* Conditions */

dcl  cleanup	        condition;
%page;
/* Program */

	utep = P_utep;
	area_ptr = P_area_ptr;
	uc_disconnected_process_list_ptr = null ();
	code = 0;

	if utep = null () then
	     call Abort (error_table_$null_info_ptr,
		"Pointer to UTE is null.");

	pdtep = ute.pdtep;
	if pdtep = null () then
	     call Abort (-1, "Null PDT entry pointer for ^a.^a ^a.",
		ute.person, ute.project, ute.tty_name);

/**** If the user has no disconnected processes, save ourselves a lot of
      work and time by just returning a null pointer to the disconnected
      process list information. */

	if user.n_disconnected = 0 then
	     goto RETURN;

	if area_ptr = null () then
	     area_ptr = get_system_free_area_ ();

	temp_list = null;
	on cleanup begin;
	     if temp_list ^= null &
		temp_list ^= uc_disconnected_process_list_ptr
	     then free temp_list -> uc_disconnected_process_list in (system_area);
	     if uc_disconnected_process_list_ptr ^= null
	     then free uc_disconnected_process_list in (system_area);
	end;

	uc_n_disconnected_processes = user.n_disconnected;
	allocate uc_disconnected_process_list in (system_area);
	uc_disconnected_process_list.version =
	     UC_DISCONNECTED_PROCESS_LIST_VERSION_1;
	uc_disconnected_process_list.n_disconnected_processes =
	     uc_n_disconnected_processes;

	ansp = as_data_$ansp;
	processes_found = 0;

	do ute_index = 1 to anstbl.current_size;
	     temp_utep = addr (anstbl.entry (ute_index));
	     if temp_utep -> ute.active > NOW_LOGGED_IN &
		temp_utep ^= utep &
		temp_utep -> ute.anonymous = 0 &
		temp_utep -> ute.person = ute.person &
		temp_utep -> ute.project = ute.project &
		temp_utep -> ute.disconnected then do;
		processes_found = processes_found + 1;	/* count */
		if processes_found >
		     uc_disconnected_process_list.n_disconnected_processes
		     then do;
		     uc_n_disconnected_processes = processes_found;
		     allocate uc_disconnected_process_list in (system_area)
			set (temp_list);
		     temp_list -> uc_disconnected_process_list.n_disconnected_processes =
			uc_disconnected_process_list.n_disconnected_processes;
		     temp_list -> uc_disconnected_process_list = uc_disconnected_process_list;
		     free uc_disconnected_process_list in (system_area);
		     uc_disconnected_process_list_ptr = temp_list;
		     temp_list = null;
		     uc_disconnected_process_list.n_disconnected_processes = processes_found;
		end;
		uc_disconnected_process_list.process (processes_found).utep = temp_utep;
	     end;
	end;

	if processes_found ^= user.n_disconnected then do;
	     call Error_No_Abort (
		"Disconnected process count = ^d; PDT entry = ^d.",
		processes_found, user.n_disconnected);
	end;

RETURN:
	P_uc_disconnected_process_list_ptr =
	     uc_disconnected_process_list_ptr;
	return;

ABORT_RETURN:
	if uc_disconnected_process_list_ptr ^= null () then do;
	     free uc_disconnected_process_list in (system_area);
	     uc_disconnected_process_list_ptr = null ();
	end;
	goto RETURN;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Stop disconnected process list operation by emitting an	       */
/* explanatory as log message, and returning nonzero code to our caller.     */
/*							       */
/* Syntax:  call Abort (code, ioa_ctl, args);			       */
/*							       */
/*							       */
/* Error_No_Abort: Add error message to as log, but do not stop	       */
/* the list operation.					       */
/*							       */
/* Syntax:  call Error_No_Abort (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_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	go to ABORT_RETURN;

Error_No_Abort:
     entry options (variable);

	sl_info = sl_info_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.severity = SL_LOG_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	return;

     end Abort;

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

/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include dialup_values;
%page; %include pdt;

dcl  pdtp		        ptr automatic init (null);	/* pdt needs it. */
%page; %include sys_log_constants;
%page; %include uc_disc_proc_list;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

end uc_list_disconnected_procs_;




		    uc_login_.pl1                   07/13/88  1113.4r w 07/13/88  0938.2      384714



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-19,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-24,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-21,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) For notification of other processes for this personid, require that
         a process exist, not just that user be logged in.
      B) Changed DETERMINE_AUTHORIZATIONS to use convert_access_class_$(minimum
         and maximum) instead of aim_check_$greater to find the minimum range
         of authorizations between the SAT, PDT and PNT.
      C) Corrected to properly enforce password expiration interval.
      D) Removed references to ute.uflags.logged_in.
      E) Make all decisions on which internal procs to run in Setup, rather
         than making some there and some in the main procedure.
      F) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1
  3) change(87-05-12,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Don't send login notifications to disconnected or UFT processes.
         Neither can receive the message or act upon an invalid login.
         (dsa 119)
      B) Don't send bad password information to UFT processes, since they
         cannot pass it along to the user (there is no user at the terminal).
  4) change(87-05-14,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Replace use of uc_validate_info.channel_info.line_type with
         ute.line_type.
      B) Correct person_id (= anonymous) in group_id of anonymous users.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_login_:
     procedure (P_uc_validate_info_ptr, P_utep, P_code);

/* Parameters */

dcl  P_uc_validate_info_ptr ptr parameter;
dcl  P_utep	        ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  authorization	        (3) bit (72) aligned;
dcl  auth_string	        char (200);
dcl  auth_string_octal      char (32);
dcl  code		        fixed bin (35) automatic;
dcl  1 flags	        structure aligned automatic,
       2 anonymous	        bit (1) unaligned,
       2 check_password     bit (1) unaligned,
       2 check_physical_security_breach
		        bit (1) unaligned,
       2 check_change_arguments
		        bit (1) unaligned,
       2 check_authorization_argument
		        bit (1) unaligned,
       2 check_daemon_access bit (1) unaligned,
       2 check_channel_access
		        bit (1) unaligned,
       2 check_channel_access_class bit (1) unaligned,
       2 check_anonymous_password bit (1) unaligned,
       2 pad1	        bit (27) unaligned;
dcl  htp		        ptr;
dcl  ip		        ptr automatic;
dcl  maybe_update_pnte      bit (1) aligned automatic;
dcl  pdtep	        ptr automatic;
dcl  pdtp		        ptr automatic;
dcl  1 pnte	        structure aligned like pnt_entry;
dcl  1 old_pnte	        structure aligned like pnt_entry;
dcl  satep	        ptr automatic;
dcl  satp		        ptr automatic;
dcl  whoptr	        ptr automatic;

/* Entries */

dcl  aim_check_$greater_or_equal
		        entry (bit (72) aligned, bit (72) aligned)
		        returns (bit (1) aligned);
dcl  aim_check_$in_range    entry (bit (72) aligned,
		        (2) bit (72) aligned)
		        returns (bit (1) aligned);
dcl  as_access_audit_$login entry (ptr, char (*));
dcl  asu_$blast_user        entry (ptr, char (*), char (*), fixed bin (35));
dcl  convert_access_class_$maximum
		        entry ((*) bit (72) aligned, fixed bin, bit (72) aligned);
dcl  convert_access_class_$minimum
		        entry ((*) bit (72) aligned, fixed bin, bit (72) aligned);
dcl  convert_access_class_$to_string_short
		        entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_range_short
		        entry ((2) bit (72) aligned, char (*),
		        fixed bin (35));
dcl  convert_status_code_   entry (fixed bin (35), char (8) aligned,
		        char (100) aligned);
dcl  display_access_class_  entry (bit (72) aligned) returns (char (32) aligned);
dcl  display_access_class_$range
		        entry ((2) bit (72) aligned)
		        returns (char (32) 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  initiate_file_	        entry (char (*), char (*), bit (*), ptr,
		        fixed bin (24), fixed bin (35));
dcl  ioa_$rs	        entry () options (variable);
dcl  ioa_$rsnnl	        entry () options (variable);
dcl  mail_table_initializer_$set_dft_proj
		        entry (char (*), char (*), fixed bin (35));
dcl  mc_check_access_$log_in_as_daemon
		        entry (char (*), char (*), fixed bin (35));
dcl  merge_access_audit_flags_
		        entry (bit (36) aligned, bit (36) aligned)
		        returns (bit (36) aligned);
dcl  pnt_manager_$admin_get_entry
		        entry (char (*), ptr, fixed bin (35));
dcl  pnt_manager_$login_get_entry
		        entry (char (*), char (*), ptr,
		        fixed bin (35));
dcl  pnt_manager_$update_entry
		        entry (ptr, bit (1) aligned,
		        bit (1) aligned, fixed bin (35));
dcl  scramble_	        entry (char (8)) returns (char (8));
dcl  ttt_info_$decode_type  entry (fixed bin, char (*), fixed bin (35));
dcl  ttt_info_$encode_type  entry (char (*), fixed bin, fixed bin (35));
dcl  up_sat_$make_sat_hash  entry (ptr, fixed bin, ptr, char (*), fixed bin (35));

/* External */

dcl  (as_error_table_$already_in_notify_msg,
     as_error_table_$bad_anon_pw,
     as_error_table_$bad_password,
     as_error_table_$bad_personid,
     as_error_table_$bad_project,
     as_error_table_$breach,
     as_error_table_$breach_msg,
     as_error_table_$cant_give_dft_auth,
     as_error_table_$cant_give_that_authorization,
     as_error_table_$dialup_error,
     as_error_table_$must_change,
     as_error_table_$must_use_generate_pw,
     as_error_table_$no_change,
     as_error_table_$no_line_permission,
     as_error_table_$not_in_pdt,
     as_error_table_$operator_not_allowed,
     as_error_table_$password_expired,
     as_error_table_$password_locked,
     as_error_table_$password_probe_mail_msg,
     as_error_table_$password_probe1_mail_msg,
     as_error_table_$password_trap,
     as_error_table_$pdt_missing,
     as_error_table_$person_auth_msg,
     as_error_table_$terminal_auth_msg,
     as_error_table_$too_many_bad_pw) fixed bin (35) ext static;
dcl  (error_table_$bad_arg,
     error_table_$bad_password,
     error_table_$id_not_found,
     error_table_$messages_off,
     error_table_$smallarg,
     error_table_$wakeup_denied) fixed bin (35) ext static;

/* Constant */

dcl  ALLOW_RETRY	        bit (1) aligned initial ("1"b)
		        internal static options (constant);
dcl  FALSE	        bit (1) aligned initial ("0"b)
		        internal static options (constant);
dcl  ME		        char (9) initial ("uc_login_")
		        internal static options (constant);
dcl  SYSTEM_LOW	        bit (72) aligned initial (""b)
		        internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b)
		        internal static options (constant);
dcl  USECS_PER_DAY	        fixed bin (71) initial (86400000000)
		        internal static options (constant);

/* Builtin */

dcl  (addr, addrel, clock, length, mod, null, rtrim, string, substr, unspec)
		        builtin;

/* Conditions */

dcl  seg_fault_error        condition;
%page;
/* Program */

/**** TBS: Fault Handler */
	call Setup ();
	call Validate_Personid ();
	if flags.check_password then
	     call Check_Password_Flags ();
	if flags.check_physical_security_breach then
	     call Check_Physical_Security_Breach ();
	if flags.check_change_arguments then
	     call Process_Change_Arguments ();
	if flags.check_authorization_argument then
	     call Check_Authorization_Argument ();
	call Validate_Projectid ();
	if flags.check_anonymous_password then
	     call Check_Anonymous_Password ();
	if flags.check_daemon_access then
	     call Check_Daemon_Access ();
	if flags.check_channel_access then
	     call Check_Channel_Access ();
	call Process_Attributes ();
	call Check_Access_Authorization ();
	if flags.check_channel_access_class then
	     call Check_Channel_Access_Class ();

	call Login ();

RETURN:
	P_code = code;
	if maybe_update_pnte then
	     if unspec (old_pnte) ^= unspec (pnte) then
		call Update_Pnte ();
	return;
%page;
Setup:
     procedure ();

	uc_validate_info_ptr = P_uc_validate_info_ptr;
	utep = P_utep;
	code = 0;

	ansp = as_data_$ansp;
	ip = as_data_$rs_ptrs (0);
	satp = as_data_$satp;
	whoptr = as_data_$whoptr;

	anstbl.current_time = clock ();

	unspec (flags) = ""b;
	if ute.process_type = PT_INTERACTIVE then do;
	     flags.check_password = TRUE;
	     flags.check_physical_security_breach = TRUE;
	     flags.check_change_arguments = TRUE;
	     flags.check_authorization_argument = TRUE;
	     flags.check_daemon_access = FALSE;
	     flags.check_channel_access = TRUE;
	     flags.check_channel_access_class = TRUE;
	end;
	else if ute.process_type = PT_ABSENTEE then
	     do;
	     flags.check_password = FALSE;
	     flags.check_physical_security_breach = FALSE;
	     flags.check_change_arguments = FALSE;
	     flags.check_authorization_argument = FALSE;
	     flags.check_daemon_access = FALSE;
	     flags.check_channel_access = FALSE;
	     flags.check_channel_access_class = FALSE;
	end;
	else if ute.process_type = PT_DAEMON then
	     do;
	     flags.check_password = FALSE;
	     flags.check_physical_security_breach = FALSE;
	     flags.check_change_arguments = TRUE;
	     flags.check_authorization_argument = TRUE;
	     flags.check_daemon_access = TRUE;
	     flags.check_channel_access = FALSE;
	     flags.check_channel_access_class = FALSE;
	end;
	else
	     call Abort (error_table_$bad_arg, ^ALLOW_RETRY);

	if ^uc_validate_info.flags.check_channel_access then
	     flags.check_channel_access = FALSE;

	if ute.anonymous = 1 then
	     do;
	     flags.anonymous = TRUE;
	     flags.check_password = FALSE;
	     flags.check_anonymous_password = uc_validate_info.flags.check_anonymous_password;
	     flags.check_change_arguments = FALSE;
	end;
	else
	     flags.anonymous = FALSE;

	anstbl.session_uid_counter = anstbl.session_uid_counter + 1;
	ute.session_uid = anstbl.session_uid_counter;
	maybe_update_pnte = FALSE;
	return;
     end Setup;
%page;
Validate_Personid:
     procedure ();

dcl  password	        char (32) automatic;

	if ute.person = "" then
	     call Abort (as_error_table_$bad_personid, ALLOW_RETRY);

	if flags.anonymous then
	     if ute.project = "" then
		do;
		ute.project = ute.person;
		return;
	     end;

	if flags.check_password then
	     do;
	     if ute.login_flags.cpw then
		password = ute.old_password;
	     else
		password = uc_validate_info.password;

	     unspec (pnte) = ""b;
	     call pnt_manager_$login_get_entry (ute.person, password, addr (pnte),
		code);
	end;
	else
	     call pnt_manager_$admin_get_entry (ute.person, addr (pnte), code);

	if code = error_table_$id_not_found then
	     call Abort (as_error_table_$bad_personid, ALLOW_RETRY);
	else if code ^= error_table_$bad_password & code ^= 0 then
	     do;
	     call Log_Error_with_Code (SL_LOG_BEEP, code,
		"Reading PNT entry for ^a.", ute.person);
	     call Abort (as_error_table_$dialup_error, ^ALLOW_RETRY);
	end;

/* If we get here, we were able to read the PNT entry.  The password,
   however, may still have been incorrect. */

	old_pnte = pnte;
	maybe_update_pnte = TRUE;

	ute.person = substr (pnte.user_id, 1, length (ute.person));
	if ute.project = "" then
	     ute.project = pnte.default_project;

	if code = error_table_$bad_password then
	     do;
	     call Bad_Password ();
	     call Abort (as_error_table_$bad_password, ALLOW_RETRY);
	end;

/**** Check to see if user is login in as an operator.  Validate his
      authorization to do so. */

	if ute.login_flags.operator then
	     if ^pnte.flags.operator then
		call Abort (as_error_table_$operator_not_allowed,
		     ALLOW_RETRY);

/**** Personid is validated */

	return;
%page;
Bad_Password:
	procedure ();

dcl  mail_for_user	        char (128) automatic;
dcl  message	        char (256) automatic;

	     pnte.n_bad_pw = pnte.n_bad_pw + 1;
	     pnte.n_bad_pw_since_good = pnte.n_bad_pw_since_good + 1;
	     pnte.time_last_bad_pw = anstbl.current_time;
	     pnte.last_bad_pw_reported = FALSE;
	     pnte.bad_pw_term_id = ute.tty_id_code;
	     pnte.bad_pw_term_type = ute.terminal_type;
	     pnte.bad_pw_line_type = ute.line_type;

	     if pnte.n_bad_pw_since_good = 1 then
		message =
		     Convert_Message (as_error_table_$password_probe1_mail_msg);
	     else
		message = Convert_Message (as_error_table_$password_probe_mail_msg);

	     if message ^= "" then
		do;
		if pnte.n_bad_pw_since_good = 1 then
		     call ioa_$rs (message, mail_for_user, (0), ute.person,
			ute.terminal_type, ute.tty_id_code);
		else
		     call ioa_$rs (message, mail_for_user, (0), ute.person,
			pnte.n_bad_pw_since_good, ute.terminal_type,
			ute.tty_id_code);

		call Send_User_Mail (ute.person, ute.project, mail_for_user,
		     pnte.default_person_authorization, code);
		if (code ^= 0) & (code ^= error_table_$wakeup_denied)
		     & (code ^= error_table_$messages_off) then
		     do;
		     call Send_User_Mail (ute.person, (pnte.default_project),
			mail_for_user, pnte.default_person_authorization, code);
		     if code = 0 then
			pnte.flags.last_bad_pw_reported = "1"b;
		end;
		else
		     pnte.flags.last_bad_pw_reported = "1"b;
	     end;
	     if mod (pnte.n_bad_pw_since_good, installation_parms.login_tries) = 0 then do;
		call Log_Coded_Error (SL_LOG_BEEP,
		     as_error_table_$too_many_bad_pw, ute.person,
		     ute.project, ute.tty_name, ute.terminal_type,
		     ute.tty_id_code);
	     end;
	     return;
	end Bad_Password;

     end Validate_Personid;
%page;
Check_Password_Flags:
     procedure ();

	if ute.login_flags.cpw & ^ute.login_flags.generate_pw & pnte.flags.generate_pw
	then
	     call Abort (as_error_table_$must_use_generate_pw, ALLOW_RETRY);

	if installation_parms.password_expiration_interval ^= 0 then
	     if ((anstbl.current_time - pnte.time_last_good_pw)
		> (installation_parms.password_expiration_interval
		* USECS_PER_DAY))
		& ((anstbl.current_time - pnte.user_validated_time)
		> (installation_parms.password_expiration_interval
		* USECS_PER_DAY)) then
		do;
		uc_validate_info.password_unused_too_long = TRUE;
		uc_validate_info.password_interval = installation_parms.password_expiration_interval;
		call Abort (as_error_table_$password_expired,
		     ^ALLOW_RETRY);
	     end;

	if ^ute.login_flags.cpw then
	     do;
	     if pnte.flags.must_change then
		do;
		if ^pnte.flags.generate_pw then
		     call Abort (as_error_table_$must_change, ALLOW_RETRY);
		else call Abort (as_error_table_$must_use_generate_pw,
			ALLOW_RETRY);
	     end;

	     if installation_parms.password_change_interval ^= 0 then
		if (anstbl.current_time - pnte.time_pw_changed)
		     > (installation_parms.password_change_interval
		     * USECS_PER_DAY) then
		     do;
		     uc_validate_info.password_expired = TRUE;
		     uc_validate_info.password_interval = installation_parms.password_change_interval;
		     if ^pnte.flags.generate_pw then
			call Abort (as_error_table_$must_change,
			     ALLOW_RETRY);
		     else call Abort (as_error_table_$must_use_generate_pw,
			     ALLOW_RETRY);
		end;
	end;

	pnte.n_good_pw = pnte.n_good_pw + 1;
	pnte.time_last_good_pw = anstbl.current_time;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* We used to check pnte.flags.last_bad_pw_reported here to decide whether   */
/* to print the message "Your password was ..." on the terminal upon login.  */
/* Since it is possible (and likely) that the user logging in will have      */
/* never seen the mail sent telling him that his password was used	       */
/* incorrectly, we remove that check and force the message on his terminal.  */
/* The theory is that if there really is someone trying to guess a password, */
/* and he does manage to succeed and get in, he will most likely delete any  */
/* mail telling the REAL user that someone was hacking.		       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if pnte.n_bad_pw_since_good > 0 &
	     ute.tag ^= TAG_UFT then			/* UFT processes cannot send msgs to user */
	     do;
	     uc_validate_info.last_bad_pw_info.time = pnte.time_last_bad_pw;
	     uc_validate_info.last_bad_pw_info.number =
		pnte.n_bad_pw_since_good;
	     uc_validate_info.last_bad_pw_info.terminal_type =
		pnte.bad_pw_term_type;
	     uc_validate_info.last_bad_pw_info.terminal_id =
		pnte.bad_pw_term_id;
	     uc_validate_info.last_bad_pw_info.line_type =
		pnte.bad_pw_line_type;
	     pnte.last_bad_pw_reported = "1"b;
	end;
	else do;					/* better than returning garbage */
	     uc_validate_info.last_bad_pw_info.time = 0;
	     uc_validate_info.last_bad_pw_info.number = 0;
	     uc_validate_info.last_bad_pw_info.terminal_type = "";
	     uc_validate_info.last_bad_pw_info.terminal_id = "";
	     uc_validate_info.last_bad_pw_info.line_type = 0;
	end;

	if pnte.last_bad_pw_reported then
	     pnte.n_bad_pw_since_good = 0;

	if pnte.flags.trap then do;
	     call Log_Coded_Error (SL_LOG_BEEP,
		as_error_table_$password_trap, ute.person, ute.project,
		ute.tty_name, ute.terminal_type, ute.tty_id_code);
	end;
	if (pnte.flags.pw_time_lock & anstbl.current_time < pnte.password_timelock)
	     | pnte.flags.lock then
	     call Abort (as_error_table_$password_locked, ^ALLOW_RETRY);

	if ute.login_flags.cpw then
	     if pnte.flags.nochange then
		call Abort (as_error_table_$no_change, ALLOW_RETRY);
	     else
		do;
		pnte.password = uc_validate_info.password;
		pnte.time_pw_changed = anstbl.current_time;
		pnte.flags.must_change = FALSE;
		uc_validate_info.changed_password = TRUE;
	     end;
	return;
     end Check_Password_Flags;
%page;
Check_Physical_Security_Breach:
     procedure ();

dcl  maximum_authorization  bit (72) aligned automatic;

	if flags.anonymous then
	     maximum_authorization = SYSTEM_LOW;
	else
	     maximum_authorization = pnte.person_authorization (2);

	if ^aim_check_$greater_or_equal (maximum_authorization,
	     uc_validate_info.channel_info.access_class_range (1)) then
	     do;
	     call Log_Coded_Error (SL_LOG_BEEP, as_error_table_$breach_msg,
		ute.person, ute.project, ute.tty_name, ute.terminal_type,
		ute.tty_id_code);

	     auth_string_octal =
		display_access_class_ (maximum_authorization);
	     call convert_access_class_$to_string_short (
		maximum_authorization, auth_string, code);
	     if code ^= 0 then
		if code = error_table_$smallarg then
		     code = 0;
		else auth_string = "";
	     call Log_Coded_Error (SL_LOG, as_error_table_$person_auth_msg,
		auth_string_octal, auth_string);

	     auth_string_octal = display_access_class_$range (
		uc_validate_info.channel_info.access_class_range);
	     call convert_access_class_$to_string_range_short (
		uc_validate_info.channel_info.access_class_range,
		auth_string, code);
	     if code ^= 0 then
		if code = error_table_$smallarg then
		     code = 0;
		else auth_string = "";
	     call Log_Coded_Error (SL_LOG, as_error_table_$terminal_auth_msg,
		auth_string_octal, auth_string);

	     call Abort (as_error_table_$breach, ^ALLOW_RETRY);
	end;
	return;
     end Check_Physical_Security_Breach;
%page;
Process_Change_Arguments:
     procedure ();

	if ute.login_flags.cdp then
	     if ^pnte.flags.nochange then
		do;
		pnte.default_project = substr (ute.project, 1, length (pnte.default_project));
		uc_validate_info.changed_default_project = TRUE;
	     end;
	     else
		call Abort (as_error_table_$no_change, ALLOW_RETRY);

	if ute.login_flags.cda then
	     if ^pnte.flags.nochange then
		do;
		pnte.default_person_authorization = ute.process_authorization;
		uc_validate_info.default_authorization_changed = TRUE;
	     end;
	     else
		call Abort (as_error_table_$no_change, ALLOW_RETRY);


	if uc_validate_info.changed_default_project then
	     do;
	     call mail_table_initializer_$set_dft_proj (rtrim (pnte.user_id),
		rtrim (pnte.default_project), code);
	     if code ^= 0 then
		call Log_Error_with_Code (SL_LOG_BEEP, code,
		     "Changing Mail Table default project for ^a to ^a",
		     pnte.user_id, pnte.default_project);
	end;
	return;
     end Process_Change_Arguments;
%page;
Check_Authorization_Argument:
     procedure ();

	if ^ute.login_flags.auth_given then
	     if flags.anonymous then
		ute.process_authorization = SYSTEM_LOW;
	     else
		ute.process_authorization = pnte.default_person_authorization;
	return;
     end Check_Authorization_Argument;
%page;
Validate_Projectid:
     procedure ();

dcl  ans		        char (64) automatic;
dcl  i		        fixed bin (35) automatic;
dcl  pdt_entryname	        char (32) automatic;
dcl  pdt_htp	        ptr automatic;
dcl  temp_person_name       char (32) automatic;

lookup_loop:
	call hash_$search (as_data_$sat_htp, ute.project, i, code);
	if code ^= 0 then
	     call Abort (as_error_table_$bad_project, ALLOW_RETRY);

	satep = addr (sat.project (i));
	if ute.project ^= project.project_id then
	     if ute.project ^= project.alias then
		do;
		call Log_Error_with_Code (SL_LOG_SILENT, -1,
		     "sat.ht has ""^a"", SAT has ""^a"" at ^p",
		     ute.project, project.project_id, satep);
		call up_sat_$make_sat_hash (satp, sat.n_projects,
		     as_data_$sat_htp, ans, code);
		if code ^= 0 then
		     do;
		     call Log_Error_with_Code (SL_LOG, code,
			"Unable to rehash sat.ht: ^a", ans);
		     call Abort (as_error_table_$dialup_error,
			^ALLOW_RETRY);
		end;
		else
		     goto lookup_loop;		/* go try the lookup again */
	     end;

	if project.state ^= 1 then
	     do;
	     call Log_Error_with_Code (SL_LOG_SILENT, -1,
		"Project ^a, state ^d, still in sat.ht",
		project.project_id, project.state);
	     call Abort (as_error_table_$bad_project, ALLOW_RETRY);
	end;

	ute.project = project.project_id;		/* in case alias */
						/* was used.     */

	if project.pdt_ptr ^= null () then
	     pdtp = project.pdt_ptr;
	else
	     do;
	     pdt_entryname = rtrim (project.project_id) || ".pdt";
	     call initiate_file_ (as_data_$pdtdir, pdt_entryname, RW_ACCESS,
		pdtp, (0), code);
	     if code ^= 0 then
		do;
		call Log_Error_with_Code (SL_LOG_SILENT, code, "^a>^a",
		     as_data_$pdtdir, project.project_id);
		call Abort (as_error_table_$pdt_missing, ALLOW_RETRY);
	     end;
	     project.pdt_ptr = pdtp;
	end;

	if project.rs_number < 0 | project.rs_number > whotab.n_rate_structures
	then
	     do;
	     call Log_Error_with_Code (SL_LOG_BEEP, -1,
		"Project ^a has invalid rate_structure number ^d. Using rate_structure 0.",
		project.project_id, project.rs_number);
	     ute.rs_number = 0;
	end;
	else
	     ute.rs_number = project.rs_number;

	temp_person_name = ute.person;

	if flags.anonymous then
	     if ^project.at.anonymous then
		call Abort (as_error_table_$not_in_pdt, ALLOW_RETRY);
	     else
		temp_person_name = "*";

	pdtep = null ();

	on seg_fault_error
	     begin;
	     call Log_Error_with_Code (SL_LOG_BEEP, -1,
		"PDT for project ^a has its damage switch set.  Login for user ^a refused.",
		ute.project, ute.person);
	     call Abort (as_error_table_$dialup_error, ^ALLOW_RETRY);
	end;
	i = pdt.ht_relp;
	revert seg_fault_error;

	if pdt.ht_relp > 0 then
	     do;
	     pdt_htp = addrel (pdtp, pdt.ht_relp);
	     if pdt_htp -> htable.id ^= "ht01" & pdt_htp -> htable.id ^= "ht02"
	     then
		do;
		call Log_Error_with_Code (SL_LOG_BEEP, -1,
		     "No hash table at ^o of ^a.pdt", pdt.ht_relp,
		     project.project_id);
	     end;
	     else
		do;
		call hash_$search (pdt_htp, temp_person_name, i, code);
		if code ^= 0 then
		     call Abort (as_error_table_$not_in_pdt, ALLOW_RETRY);
		pdtep = addr (pdt.user (i));
		if user.state ^= 1 then
		     do;
		     call Log_Error_with_Code (SL_LOG_BEEP, -1,
			"User ^a, state ^d, still in hash table of ^a.pdt",
			temp_person_name, user.state, project.project_id);
		     call Abort (as_error_table_$not_in_pdt, ALLOW_RETRY);
		end;

		if user.person_id ^= temp_person_name then
		     do;
		     call Log_Error_with_Code (SL_LOG_BEEP, -1,
			"Hash table of ^a.pdt has ^a, pdt has ^a, at ^p",
			project.project_id, temp_person_name,
			user.person_id, pdtep);
		     pdtep = null ();
		end;
	     end;
	end;

	if pdtep = null then
	     do i = 1 to pdt.current_size while (pdtep = null ());
	     pdtep = addr (pdt.user (i));
	     if user.state = 1 then
		do;
		if user.person_id ^= temp_person_name then
		     pdtep = null ();
	     end;
	     else
		pdtep = null ();
	end;

	if pdtep = null () then
	     call Abort (as_error_table_$not_in_pdt, ALLOW_RETRY);

	ute.pdtep = pdtep;
	ute.uprojp = satep;
	return;
     end Validate_Projectid;
%page;
Check_Anonymous_Password:
     procedure ();

	if user.password ^= "" then
	     if scramble_ ((user.password)) ^= uc_validate_info.password then
		call Abort (as_error_table_$bad_anon_pw, ALLOW_RETRY);
	return;
     end Check_Anonymous_Password;
%page;
Check_Daemon_Access:
     procedure ();

dcl  group_id	        char (32) automatic;

	call ioa_$rsnnl ("^a.^a.z", group_id, (0), ute.person, ute.project);
	call mc_check_access_$log_in_as_daemon (group_id, ute.tty_name, code);
	if code ^= 0 then
	     call Abort (code, ^ALLOW_RETRY);
	return;
     end Check_Daemon_Access;
%page;
Check_Channel_Access:
     procedure ();

dcl  group_id	        char (32) automatic;
dcl  mode		        bit (36) aligned automatic;
dcl  type		        char (8) automatic;

	if ute.login_flags.dial_pw then
	     type = "dial";
	else if ute.login_flags.slave_pw then
	     type = "slave";
	else
	     type = "login";

	call ioa_$rsnnl ("^[anonymous^s^;^a^].^a.^a", group_id, (0),
	     (ute.anonymous = 1), ute.person, ute.project, ute.tag);

	call hcs_$get_user_access_modes (as_data_$rcpdir,
	     rtrim (ute.tty_name) || ".acs", group_id, 0, mode, (""b), code);
	if code ^= 0 then
	     do;
	     call Log_Error_with_Code (SL_LOG, code,
		"Unable to check access for channel ^a.", ute.tty_name);
	     mode = ""b;
	end;

	if (mode & RW_ACCESS) ^= RW_ACCESS then
	     call Abort (as_error_table_$no_line_permission, ^ALLOW_RETRY);
	return;
     end Check_Channel_Access;
%page;
Process_Attributes:
     procedure ();

dcl  bstemp	        bit (36) aligned automatic;

/**** Don't let user set attributes disallowed by SAT or PDT */
	string (ute.ur_at) = string (ute.ur_at) &
	     ((string (user.at) & string (project.at))
	     | USER_ATTRIBUTES_always_allowed);

/**** Turn on attributes which user cannot set. */
	string (ute.at) =
	     string (ute.at) | ^USER_ATTRIBUTES_settable_by_user;

/**** Turn on defaults for attributes user didn't specify. */
	string (ute.at) = string (ute.at) |
	     (string (user.at) & USER_ATTRIBUTES_default_in_pdt &
	     ^string (ute.ur_at));

/**** Turn off attributes denied by SAT or PDT */
	string (ute.at) = string (ute.at) &
	     ((string (user.at) & string (project.at))
	     | USER_ATTRIBUTES_always_allowed);

/**** Remember attributes set by user. */
	bstemp = string (ute.at) &
	     (string (ute.ur_at) | USER_ATTRIBUTES_settable_by_user);

/**** Turn off attributes user is allowed to set. */
	string (ute.at) = string (ute.at) &
	     ^USER_ATTRIBUTES_settable_by_user;

/**** Set user-settable attributes according to user wishes. */
	string (ute.at) = string (ute.at) | bstemp;

	if ute.at.guaranteed_login then
	     ute.at.nobump = "1"b;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* The process-saving attributes, disconnect_ok and save_on_disconnect, need */
/* special handling.  After the above logic, each is on in ute.at only if it */
/* was on in both SAT and PDT.				       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****  First we force both on if both were on in SAT. */
	if project.at.save_on_disconnect & project.at.disconnect_ok then
	     ute.at.save_on_disconnect, ute.at.disconnect_ok = "1"b;

/****  Then turn on save_on_disconnect if on in PDT, even if off in SAT */
	if user.at.save_on_disconnect then
	     ute.at.save_on_disconnect = "1"b;

/****  Process saving is impossible for anonymous users. */
	if flags.anonymous then
	     ute.at.save_on_disconnect, ute.at.disconnect_ok = ""b;

     end Process_Attributes;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Here we determine the user process authorization and maximum	       */
/* authorization.  We also set the audit flags.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Check_Access_Authorization:
     procedure ();

/**** Currently, we only allow anonymous users to log in at system_low
      authorization.  To lift this restriction, all that is necessary
      is to delete the following statement. */
	if flags.anonymous then
	     ute.process_authorization = SYSTEM_LOW;

	ute.process_authorization_range (*) = ""b;

/**** Set the process minimum authorization to the maximum of the following */
	authorization (1) = user.user_authorization (1);
	authorization (2) = project.project_authorization (1);
	if ute.anonymous = 1 then			/* anonymous have no pnte */
	     authorization (3) = project.project_authorization (1);
	else authorization (3) = pnte.person_authorization (1);
	call convert_access_class_$maximum (authorization, 3, ute.process_authorization_range (1));

/**** Set the process maximum authorization to the minimum of the following */
	authorization (1) = user.user_authorization (2);
	authorization (2) = project.project_authorization (2);
	if ute.anonymous = 1 then			/* anonymous have no pnte */
	     authorization (3) = project.project_authorization (2);
	else authorization (3) = pnte.person_authorization (2);
	call convert_access_class_$minimum (authorization, 3, ute.process_authorization_range (2));

/**** Merge the audit flags from the SAT and the PNT.  If the user is
      anonymous, there is no PNT entry se we set the ute.audit to the SAT
      value. */
	if flags.anonymous then
	     ute.audit = project.audit;
	else
	     ute.audit = merge_access_audit_flags_ (project.audit, pnte.audit);

/**** Compare the requested or default authorization with the computed
      authorization range and reject the login if this authorization is
      outside the allowed range. */
	if ^aim_check_$in_range (ute.process_authorization,
	     ute.process_authorization_range) then
	     do;
	     if ute.login_flags.auth_given | ute.process_type = PT_ABSENTEE
	     then
		call Abort (as_error_table_$cant_give_that_authorization,
		     ALLOW_RETRY);
	     else
		call Abort (as_error_table_$cant_give_dft_auth,
		     ALLOW_RETRY);
	end;

     end Check_Access_Authorization;
%page;
Check_Channel_Access_Class:
     procedure ();

	if ^aim_check_$in_range (ute.process_authorization,
	     uc_validate_info.channel_info.access_class_range) then do;

	     if ute.login_flags.auth_given | ute.process_type = PT_ABSENTEE then
		call Abort (as_error_table_$cant_give_that_authorization,
		     ALLOW_RETRY);
	     else
		call Abort (as_error_table_$cant_give_dft_auth,
		     ALLOW_RETRY);
	end;
     end Check_Channel_Access_Class;
%page;
Login:
     procedure ();

dcl  temp_code	        fixed bin (35) automatic;
dcl  temp_coded_type        fixed bin automatic;
dcl  temp_terminal_type     char (32) automatic;

	ute.login_result = 0;
	ute.active = NOW_LOGGED_IN;
	ute.login_time = anstbl.current_time;
	call as_access_audit_$login (utep, "");
	if ^flags.anonymous then
	     do;

/**** Tell caller about last login info */

	     uc_validate_info.last_login_info.time = user.last_login_time;
	     if user.last_login_type = 0 then		/* no such thing, old type */
		temp_coded_type = user.last_login_line_type;
	     else
		temp_coded_type = user.last_login_type;
	     call ttt_info_$decode_type (temp_coded_type, temp_terminal_type, code)
		;
	     if code ^= 0 then
		temp_terminal_type = "UNKNOWN";
	     uc_validate_info.last_login_info.terminal_type =
		temp_terminal_type;
	     uc_validate_info.last_login_info.terminal_id =
		user.last_login_unit;
	     uc_validate_info.last_login_info.line_type =
		user.last_login_line_type;

/**** Update last login info for next time */

	     user.last_login_time = anstbl.current_time;
	     user.last_login_unit =
		ute.tty_id_code;
	     call ttt_info_$encode_type (ute.terminal_type,
		temp_coded_type, temp_code);
	     user.last_login_type = temp_coded_type;
	     if temp_code ^= 0 then
		user.last_login_type = 0;
	     user.last_login_line_type = ute.line_type;

/**** Tell caller about number of disconnected processes. */

	     uc_validate_info.number_disconnected_processes =
		user.n_disconnected;
	end;

/**** Update the who table */

	call Update_Whotable ();

/**** Notify other login instances of this login */

	call Notify_Other_Instances ();
	code = 0;
	return;
%page;
Notify_Other_Instances:
	procedure ();

dcl  code		        fixed bin (35) automatic;
dcl  i		        fixed bin automatic;
dcl  mail_for_user	        char (256);
dcl  notified_instance      bit (1) aligned automatic;
dcl  temp_lth	        fixed bin (21) automatic;
dcl  temp_string	        char (100) automatic;
dcl  temp_utep	        ptr automatic;

	     notified_instance = FALSE;
	     do i = 1 to anstbl.current_size while (^notified_instance);
		temp_utep = addr (anstbl.entry (i));
		if temp_utep ^= utep &
		     temp_utep -> ute.active >= NOW_HAS_PROCESS &
		     temp_utep -> ute.anonymous = 0 &
		     temp_utep -> ute.person = ute.person &
		     ^temp_utep -> ute.disconnected &
		     temp_utep -> ute.tag ^= TAG_UFT then do;
		     temp_string = Convert_Message (as_error_table_$already_in_notify_msg);
		     call ioa_$rsnnl (temp_string, mail_for_user, temp_lth,
			ute.person, ute.person, ute.project,
			ute.terminal_type, ute.tty_id_code);
		     call Send_User_Mail (temp_utep -> ute.person,
			temp_utep -> ute.project,
			substr (mail_for_user, 1, temp_lth),
			ute.process_authorization, code);
		     if code = 0 then
			notified_instance = TRUE;
		     else do;
			call asu_$blast_user (temp_utep, mail_for_user,
			     (""), code);
			if code = 0 then
			     notified_instance = TRUE;
		     end;
		end;
	     end;
	     return;
	end Notify_Other_Instances;
     end Login;
%page;
Abort:
     procedure (P_code, P_allow_retry);

dcl  P_code	        fixed bin (35) parameter;
dcl  P_allow_retry	        bit (1) aligned parameter;

dcl  status_code_string     char (8) aligned automatic;

	code = P_code;
	if code ^= 0 then
	     call convert_status_code_ (code, status_code_string, (""));
	else status_code_string = "";

	if P_allow_retry then
	     ute.login_result = 2;			/* allow retry */
	else ute.login_result = 1;			/* don't allow retry */
	ute.failure_reason = 1;			/* 1 = "lg_ctl_" said no */
	call as_access_audit_$login (utep, (status_code_string));
	goto RETURN;
     end Abort;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error_with_Code: log an error via sys_log_$general and continue       */
/* execution.						       */
/*							       */
/* Syntax:  call Log_Error_with_Code (severity, code, ioa_ctl, args);	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Log_Error_with_Code:
     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));

     end Log_Error_with_Code;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Coded_Error: log an error via sys_log_$general and continue	       */
/* execution.						       */
/*							       */
/* Syntax:  call Log_Error_with_Code (severity, ioa_ctl_in_error_code, args); */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


Log_Coded_Error:
     procedure options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_sev_coded_msg;
	sl_info.caller = ME;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));

     end Log_Coded_Error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
%page;
Convert_Message:
     procedure (P_code) returns (char (100) varying);

dcl  P_code	        fixed bin (35) parameter;
dcl  message	        char (100) aligned automatic;

	call convert_status_code_ (P_code, (""), message);
	return (rtrim (message));

     end Convert_Message;
%page;
Update_Pnte:
     procedure ();

	call pnt_manager_$update_entry (addr (pnte),
	     (uc_validate_info.changed_password), FALSE, code);
	maybe_update_pnte = FALSE;
	if code ^= 0 then
	     do;
	     call Log_Error_with_Code (SL_LOG_BEEP, code,
		"Error updating PNT entry for ^a.", ute.person);
	     call Abort (as_error_table_$dialup_error, ALLOW_RETRY);
	end;
	return;
     end Update_Pnte;
%page;
%page;
Send_User_Mail:
     procedure (P_personid, P_projectid, P_message, P_access_class, P_code);

dcl  P_personid	        char (*) parameter;
dcl  P_projectid	        char (*) parameter;
dcl  P_message	        char (*) parameter;
dcl  P_access_class	        bit (72) aligned parameter;
dcl  P_code	        fixed bin (35) parameter;

dcl  pdt_name	        char (32) automatic;
dcl  send_mail_$access_class entry (char (*), char (*), ptr, bit (72) aligned, fixed bin (35));

	unspec (send_mail_info) = ""b;
	send_mail_info.version = send_mail_info_version_2;
	send_mail_info.sent_from = "login";
	send_mail_info.switches.wakeup = TRUE;
	send_mail_info.always_add = TRUE;

	call ioa_$rsnnl ("^a.^a", pdt_name, (0), P_personid, P_projectid);
	call send_mail_$access_class (pdt_name, rtrim (P_message), addr (send_mail_info), P_access_class, code);
	if (code = 0) | (code = error_table_$wakeup_denied)
	     | (code = error_table_$messages_off) then
	     P_code = 0;
	else P_code = code;
	return;
%page; %include send_mail_info;
     end Send_User_Mail;
%page;
Update_Whotable:
     procedure ();

/**** Publish the login in the whotab */

dcl  whotab_idx	        fixed bin automatic;

	whoptr = as_data_$whoptr;
	whotab.n_users = whotab.n_users + 1;
	if ute.at.nolist then do;
	     whotab_idx = 0;
	     ute.whotabx = 0;
	end;
	else do;
	     if whotab.freep = 0 then do;		/* no free slots up to max */
		whotab.laste = whotab.laste + 1;
		whotab_idx = whotab.laste - whotab.laste_adjust;
	     end;
	     else do;				/* have a free slot */
		whotab_idx = whotab.freep;
		whotab.freep = whotab.e (whotab_idx).chain;
	     end;
	     ute.whotabx = whotab_idx;
	     if ute.anonymous = 1 then
		whotab.e (whotab_idx).person = "anonymous";
	     else whotab.e (whotab_idx).person = ute.person;
	     whotab.e (whotab_idx).project = ute.project;
	     whotab.e (whotab_idx).units = 0;		/* filled in later */
	     whotab.e (whotab_idx).timeon = anstbl.current_time;
	     whotab.e (whotab_idx).anon = ute.anonymous;
	     whotab.e (whotab_idx).stby = 0;		/* later */
	     whotab.e (whotab_idx).active = NOW_LOGGED_IN;
	     whotab.e (whotab_idx).idcode = ute.tty_id_code;
	     whotab.e (whotab_idx).group = "";		/* later */
	     whotab.e (whotab_idx).cant_bump_until = 0;	/* later */
	     whotab.e (whotab_idx).proc_type = ute.process_type;
	     whotab.e (whotab_idx).process_authorization = ute.process_authorization;
	     whotab.e (whotab_idx).fg_abs, whotab.e (whotab_idx).disconnected, whotab.e (whotab_idx).suspended = FALSE;
	end;

	if ute.process_type = PT_DAEMON then		/* daemon process */
	     whotab.n_daemons = whotab.n_daemons + 1;
	else if ute.process_type = PT_ABSENTEE then do;	/* absentee process */
	     if ute.queue > 0 then do;		/* background absentee */
		whotab.abs_users = whotab.abs_users + 1;
		if whotab_idx > 0 then
		     whotab.e (whotab_idx).fg_abs = FALSE;
	     end;
	     else do;				/* foreground absentee */
		whotab.fg_abs_users = whotab.fg_abs_users + 1;
		if whotab_idx > 0 then
		     whotab.e (whotab_idx).fg_abs = TRUE;
	     end;
	end;
	return;
     end Update_Whotable;

/* format: off */
%page; %include access_mode_values;
%page; %include as_data_;
%page; %include answer_table;
%page; %include dialup_values;
%page; %include hashst;
%page; %include installation_parms;
%page; %include line_types;
%page; %include pdt;
%page; %include pnt_entry;
%page; %include sat;
%page; %include sys_log_constants;
%page; %include uc_validate_info;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

     end uc_login_;




		    uc_logout_.pl1                  07/13/88  1113.4r w 07/13/88  0938.2       60489



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,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-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use sys_log_$general to report errors.
      B) Correct error in maintenance of whotab.
  4) change(87-05-20,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     When an MNA user logs in, a UTE is created.  When this user connects to an
     existing process, that proc's UTE is retained and the login UTE is freed;
     but the whotab is never updated to reflect freeing of the login UTE.
      A) Add uc_logout_$reconnect to do all aspects of logging out the login
         UTE except for auditing the LOGOUT.  Instead,
         uc_setup_process_connect_ audits a CONNECT operation.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_logout_:
     procedure (P_utep, P_added_info);

/* Parameters */

dcl  P_added_info	        char (*) parameter;
dcl  P_utep	        ptr parameter;

/* Automatic */

dcl  added_info	        char (32) automatic;
dcl  reconnect_sw	        bit (1);
dcl  satep	        ptr automatic;
dcl  whoptr	        ptr automatic;

/* Entries */

dcl  as_access_audit_$logout entry (ptr, char (*));
dcl  load_ctl_$unload       entry (ptr, fixed bin);
dcl  terminate_file_        entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* External */

dcl  error_table_$action_not_performed fixed bin(35) ext static;

/* Constants */

dcl (FALSE	        init("0"b),
     TRUE		        init("1"b)) bit(1) int static options(constant);
dcl  ME		        char(10) int static options(constant) init("uc_logout_");

/* Builtins */

dcl  (addr, null)	        builtin;

%page;
/* Program */
	reconnect_sw = FALSE;
	go to COMMON;

reconnect:
	entry (P_utep, P_added_info);

	reconnect_sw = TRUE;
	go to COMMON;

COMMON:	utep = P_utep;
	added_info = P_added_info;

	call Setup ();

	if ute.active ^= NOW_LOGGED_IN then
	     call Abort (error_table_$action_not_performed,
		"UTE (^d, ^p in ^a) not logged in (active= ^a, ^d).",
		ute.ute_index, utep, TABLE_NAMES(ute.process_type),
		ACTIVE_VALUES(ute.active), ute.active);

	call Update_Whotab ();			/* Make sure whotab gets updated.  Do it first. */

	if ute.uflags.proc_create_ok then
	     call load_ctl_$unload (utep, ute.process_type);

	if ute.uprojp ^= null () then do;
	     satep = ute.uprojp;
	     if project.n_users <= 0 then
		if project.project_id ^= "SysDaemon" then do;
		     call terminate_file_ (project.pdt_ptr, 0,
			TERM_FILE_TERM, (0));
		     ute.pdtep = null ();
		end;
	end;

	ute.active = NOW_DIALED;

	if ^reconnect_sw then			/* reconnect audited in uc_setup_process_connect_ */
	     call as_access_audit_$logout (utep, added_info);

RETURN:	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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_BEEP;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	goto RETURN;

     end Abort;
%page;
Setup:
     procedure ();

	ansp = as_data_$ansp;
	return;
     end Setup;
%page;
Update_Whotab:
     procedure ();

dcl  whotab_idx	        fixed bin automatic;

	whoptr = as_data_$whoptr;

	whotab.n_users = whotab.n_users - 1;
	whotab.n_units = whotab.n_units - ute.user_weight;
	whotab_idx = ute.whotabx;
	if whotab_idx ^= 0 then
	     do;
	     whotab.e (whotab_idx).active = NOW_FREE;
	     whotab.e (whotab_idx).person = "";
	     whotab.e (whotab_idx).project = "";
	     whotab.e (whotab_idx).chain = whotab.freep;	/* chain free entries together */
	     whotab.freep = whotab_idx;		/* on top of free queue */
	     ute.whotabx = 0;
	end;

	if ute.process_type = PT_ABSENTEE then do;
	     if ute.queue > 0 then			/* background absentee */
		whotab.abs_users = whotab.abs_users - 1;
	     else whotab.fg_abs_users = whotab.fg_abs_users - 1;
	end;
	else if ute.process_type = PT_DAEMON then
	     whotab.n_daemons = whotab.n_daemons - 1;
	return;
     end Update_Whotab;

/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include dialup_values;
%page; %include sat;

dcl  satp		        ptr automatic init (null);	/* sat needs it  */
%page; %include sys_log_constants;
%page; %include terminate_file;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

     end uc_logout_;




		    uc_ls_connect_request_.pl1      08/04/87  1510.9rew 08/04/87  1510.9       29520



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initially coded.
  2) change(87-05-16,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Simplified code.
      B) Removed unreferenced declarations.
      C) Added pnotice.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_connect_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;

/* Entries */

dcl  uc_setup_process_connect_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, ptr, fixed bin (35));


/* Constants */

dcl  TRUE bit(1) int static options(constant) init("1"b);
     

/* Builtins */

dcl  null		        builtin;

%page;
/* Program */

	code = 0;

	call uc_setup_process_connect_ (P_ls_request_server_info_ptr,
	     P_ls_request_ptr, P_ls_request_lth, P_ls_response_ptr,
	     P_ls_response_lth, P_ls_ipc_reply_ptr, null (), code);
	if code = 0 then do;
	     ls_response_ptr = P_ls_response_ptr;
	     login_server_process_response.flags.connected = TRUE;
	end;

RETURN:
	P_code = code;
	return;

%page; %include login_server_messages;

end uc_ls_connect_request_;




		    uc_ls_create_request_.pl1       07/13/88  1113.4r w 07/13/88  0938.2      133677



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-24,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-24,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Upgrade to use sys_log_$general for reporting errors.
      B) Correct setting of attributes.
      C) Updated for change to user_table_entry.incl.pl1.
      D) Correct coding standard violations.
      E) Updated to pass login_server_process_request.minimum_ring to
         uc_create_process_check_ for testing.
  3) change(87-05-04,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Avoid reference to login_server_process_request.login_arguments if
         login_server_process_request.n_args = 0.
  4) change(87-05-13,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Move act_ctl_$open_account call from here into uc_create_process_.
      B) Set login_server_process_response.status_code to code returned by
         uc_create_process_ if error occurs.  Also turn of
         ute.uflags.proc_create_ok in such case.
      C) Set login_server_process_response.brief from ute.at.brief.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_create_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  check_code	        fixed bin (35) automatic;
dcl  code		        fixed bin (35) automatic;
dcl  reason	        char (8) aligned automatic;
dcl  temp		        fixed bin (17) automatic;

/* Based */

dcl  argstring	        char (ute.ln_args) based (ute.args_ptr);
dcl  lengths	        (ute.arg_count) based (ute.arg_lengths_ptr) fixed bin;
dcl  system_area	        area based (system_area_ptr);

/* Entries */

dcl  as_access_audit_$process entry (ptr, fixed bin, char (*));
dcl  convert_status_code_   entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  get_system_free_area_  entry () returns (ptr);
dcl  ioa_$rsnnl	        entry () options (variable);
dcl  uc_create_process_     entry (ptr, fixed bin (35));
dcl  uc_create_process_check_ entry (ptr, ptr, fixed bin (35));
dcl  user_table_mgr_$utep_from_handle entry (bit (72) aligned) returns (ptr);

/* Internal */

dcl  system_area_ptr        ptr int static init (null);

/* External */

dcl  as_error_table_$already_logged_in fixed bin (35) ext static;
dcl  error_table_$bad_arg   fixed bin (35) ext static;
dcl  error_table_$id_not_found fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (21) initial ("uc_ls_create_request_") internal static options (constant);
dcl  NL		        char (1) int static options (constant) init ("
");
dcl  FALSE	        bit (1) aligned initial ("0"b) internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtins */

dcl  (addr, currentsize, length, null, rtrim, substr, unspec) builtin;
%page;
/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;

	code = 0;

	utep = user_table_mgr_$utep_from_handle (
	     login_server_process_request.handle);
	if utep = null () then
	     call Abort (SL_LOG_SILENT, error_table_$id_not_found,
		"Could not locate user table entry for handle ^24.3b.",
		login_server_process_request.handle);

	if ute.person ^= login_server_process_request.person_id |
	     ute.project ^= login_server_process_request.project_id then
	     call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		"Person.Project in request (^a.^a) don't match ute (^a.^a).",
		login_server_process_request.person_id,
		login_server_process_request.project_id,
		ute.person, ute.project);

	if login_server_process_request.switch_flags.warn_given then do;
	     ute.ur_at.no_warning = TRUE;
	     ute.at.no_warning =
		^login_server_process_request.switch_values.warn;
	end;
	if login_server_process_request.switch_flags.force_given then do;
	     ute.ur_at.guaranteed_login = TRUE;
	     ute.at.guaranteed_login =
		login_server_process_request.switch_values.force;
	end;
	if login_server_process_request.switch_flags.save_given then do;
	     ute.ur_at.save_on_disconnect = TRUE;
	     ute.at.save_on_disconnect =
		login_server_process_request.switch_values.save_on_disconnect;
	end;
	if login_server_process_request.switch_flags.preempt_given then do;
	     ute.ur_at.bumping = TRUE;
	     ute.at.bumping =
		login_server_process_request.switch_values.preempt;
	end;
	else ute.at.bumping = TRUE;
	if login_server_process_request.switch_flags.brief_given then do;
	     ute.ur_at.brief = TRUE;
	     ute.at.brief = login_server_process_request.switch_values.brief;
	end;

	if login_server_process_request.other_flags.init_ring_given then
	     ute.initial_ring = login_server_process_request.initial_ring;
	else ute.initial_ring = -1;

	if login_server_process_request.other_flags.immediate then
	     ute.uflags.user_specified_immediate = TRUE;
	if login_server_process_request.other_flags.no_start_up then do;
	     ute.ur_at.nostartup = TRUE;
	     ute.at.nostartup = TRUE;
	end;

	if login_server_process_request.home_dir ^= "" then do;
	     temp = length (rtrim (login_server_process_request.home_dir));
	     if temp > length (ute.home_dir) then
		call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		     "Home_dir (^a) too long (>d chars).",
		     login_server_process_request.home_dir,
		     length (ute.home_dir));
	     ute.home_dir =
		substr (login_server_process_request.home_dir, 1,
		length (ute.home_dir));
	end;
	if login_server_process_request.outer_module ^= "" then
	     ute.outer_module = login_server_process_request.outer_module;
	if login_server_process_request.process_overseer ^= "" then do;
	     temp =
		length (rtrim (login_server_process_request.process_overseer));
	     if temp > length (ute.init_proc) then
		call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		     "Process overseer (^a) too long (>^d chars).",
		     login_server_process_request.process_overseer,
		     length (ute.init_proc));
	     ute.init_proc =
		substr (login_server_process_request.process_overseer, 1,
		length (ute.init_proc));
	     ute.uflags.ip_given = TRUE;
	     ute.ip_len = temp;
	end;
	if login_server_process_request.subsystem ^= "" then do;
	     temp = length (rtrim (login_server_process_request.subsystem));
	     if temp > length (ute.init_proc) - ute.ip_len then
		call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		     "Subsystem (^a) too long (>d chars).",
		     login_server_process_request.subsystem,
		     length (ute.init_proc) - ute.ip_len);
	     ute.uflags.ss_given = TRUE;
	     substr (ute.init_proc, ute.ip_len + 1, temp) =
		login_server_process_request.subsystem;
	     ute.ss_len = temp;
	end;

	ute.arg_count = login_server_process_request.n_args;
	if ute.arg_count > 0 then do;
	     ls_process_request_n_args = login_server_process_request.n_args;
	     ls_process_request_arg_string_length =
		login_server_process_request.arg_string_length;
	     ute.ln_args = login_server_process_request.arg_string_length;
	     if system_area_ptr = null then
		system_area_ptr = get_system_free_area_ ();
	     allocate lengths in (system_area);
	     allocate argstring in (system_area);
	     if ute.ln_args <= 0 then
		lengths (*) = 0;
	     else do;
		lengths (*) =
		     login_server_process_request.args (*).arg_length;
		argstring = login_server_process_request.arg_string;
	     end;
	end;
	else ute.ln_args = 0;

	call uc_create_process_check_ (utep, ls_request_ptr, check_code);

	call Setup_Create_Response ();

	if check_code ^= 0 then do;
	     call convert_status_code_ (check_code, reason, (""));
	     call as_access_audit_$process (utep, -AS_AUDIT_PROCESS_CREATE,
		(reason));
	     if check_code = as_error_table_$already_logged_in then
		login_server_process_response.flags.already_logged_in =
		     TRUE;
	end;
	else do;
	     call uc_create_process_ (utep, code);
	     if code ^= 0 then do;
		login_server_process_response.status_code = code;
		call Abort (SL_LOG, code, "Creating process for ^a.^a.",
		     login_server_process_request.person_id,
		     login_server_process_request.project_id);
	     end;

	     login_server_process_response.login_instance =
		user.n_interactive;
	     login_server_process_response.process_id = ute.proc_id;
	     login_server_process_response.flags.created = TRUE;
	     login_server_process_response.flags.brief = ute.at.brief;
	     call Set_Start_Event_Channel ();
	end;

RETURN:
	P_code = code;
	return;
%page;
Setup_Create_Response:
     procedure ();

dcl  message_buffer	        char (as_data_$ls_message_buffer_cur_lth)
		        based (as_data_$ls_message_buffer_ptr);

	ls_response_ptr = P_ls_response_ptr;
	ls_process_response_accounting_message_length = 0;/* initially */
	unspec (login_server_process_response) = ""b;

	login_server_process_response.header.message_type =
	     LS_PROCESS_RESPONSE;
	login_server_process_response.header.header_pad = ""b;
	login_server_process_response.header.version =
	     LOGIN_SERVER_PROCESS_RESPONSE_VERSION_1;

	login_server_process_response.status_code = check_code;
	login_server_process_response.authorization =
	     ute.process_authorization;
	call ioa_$rsnnl ("^[anonymous^s^;^a^].^a.^a",
	     login_server_process_response.process_group_id, (0),
	     (ute.anonymous = 1), ute.person, ute.project, ute.tag);
	login_server_process_response.process_number = 0; /* for create */

	pdtep = ute.pdtep;				/* used below */

	login_server_process_response.n_disconnected_processes =
	     user.n_disconnected;
	if ute.login_result = 1 then
	     login_server_process_response.flags.disconnect = TRUE;
	else login_server_process_response.flags.disconnect = FALSE;

	login_server_process_response.flags.anonymous =
	     (ute.anonymous = 1);

	login_server_process_response.initial_ring = ute.initial_ring;

	ls_process_response_accounting_message_length =
	     as_data_$ls_message_buffer_cur_lth;
	login_server_process_response.accounting_message_length =
	     ls_process_response_accounting_message_length;
	login_server_process_response.accounting_message =
	     rtrim (message_buffer, NL);

	as_data_$ls_message_buffer_cur_lth = 0;		/* reset to nothing */

	P_ls_response_lth = currentsize (login_server_process_response);
	return;
     end Setup_Create_Response;
%page;
Set_Start_Event_Channel:
     procedure ();

dcl  code		        fixed bin (35) automatic;
dcl  r_factor	        fixed bin (35) automatic;
dcl  r_offset	        fixed bin (18) automatic;

dcl  hphcs_$get_ipc_operands entry (bit (36) aligned, fixed bin (18), fixed bin (35), fixed bin (35));
dcl  ipc_validate_$encode_event_channel_name entry (fixed bin (18), fixed bin (35), bit (3) aligned,
		        fixed bin (15), fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (71));

/**** We must construct an event channel which will pass the IPC event
      channel validation tests. To do this, we must learn the values of
      R-Offset and R-Factor for the process. */

	call hphcs_$get_ipc_operands (ute.proc_id, r_offset, r_factor, code);
	if code = 0 then do;
	     call ipc_validate_$encode_event_channel_name (r_offset, r_factor,
		"000"b /* flags */, 1 /* index */, 4 /* ring */,
		"1"b /* regular */, 1 /* unique id */,
		login_server_process_response.start_event_channel);
	end;
	else do;
	     login_server_process_response.start_event_channel = 0;
	     call Abort (SL_LOG_BEEP, code,
		"Retrieving the values of R-Offset and R-Factor for ^w (^a.^a)",
		ute.proc_id, ute.person, ute.project);
	end;
     end Set_Start_Event_Channel;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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 RETURN;

     end Abort;

/* format: off */
%page; %include access_audit_bin_header;
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include pdt;

dcl  pdtp ptr automatic init (null);			/* pdt needs it  */
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;

end uc_ls_create_request_;




		    uc_ls_destroy_request_.pl1      07/13/88  1113.4r w 07/13/88  0938.2       45936



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_destroy_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;

/* Entries */

dcl  asu_$send_term_signal  entry (ptr, fixed bin) returns (bit (1) aligned);
dcl  dpg_		        entry (ptr, char (*));
dcl  uc_setup_process_connect_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, ptr, fixed bin (35));

/* Constant */

dcl  ME		        char (22) initial ("uc_ls_destroy_request_") internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtins */

dcl (addr, null)	        builtin;

%page;
/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	code = 0;

	call uc_setup_process_connect_ (ls_request_server_info_ptr,
	     ls_request_ptr, P_ls_request_lth, P_ls_response_ptr,
	     P_ls_response_lth, ls_reply_message_ptr, utep, code);
	if code ^= 0 then
	     call Abort (code, "Destroying process for ^a.^a failed.",
	     login_server_process_request.person_id,
	     login_server_process_request.project_id);

/**** Tell the request server not to send a reply for this request, yet. */

	P_ls_ipc_reply_ptr -> ls_reply_message.flags.do_not_reply = TRUE;
	P_ls_response_lth = 0;
	ute.logout_type = "dest";
	ute.destroy_flag = WAIT_DESTROY_REQUEST;

	if login_server_process_request.other_flags.immediate then
	     call dpg_ (utep, "destroy immediate");
	else if ^asu_$send_term_signal (utep, PT_DESTROY_REQUEST) then
	     call dpg_ (utep, "destroy");
	else ;					/* sent trm_ signal; go away until response comes in */

RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0 then go to RETURN;

     end Abort;

/* format: off */
%page; %include dialup_values;
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;

end uc_ls_destroy_request_;




		    uc_ls_dial_request_.pl1         07/13/88  1113.4r w 07/13/88  0938.2       69777



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
  3) change(87-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use sys_log_$general to report errors.
  4) change(87-06-09,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Save process ID of target process in ute for dialed terminal.
         uc_proc_term_handler_, when invoked to bump the dialed terminal, can
         then include proper process id in the terminate response message.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr,insnl */

uc_ls_dial_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr
		        ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  target_utep	        ptr automatic;

/* Entries */

dcl  ioa_$rsnnl	        entry () options (variable);
dcl  uc_dial_	        entry (ptr, char (*), char (*), char (*), char (*), (2) bit (72) aligned, ptr, fixed bin (35))
		        ;
dcl  uc_logout_	        entry (ptr, char (*));
dcl  user_table_mgr_$utep_from_handle
		        entry (bit (72) aligned) returns (ptr);

/* External */

dcl  error_table_$id_not_found
		        fixed bin (35) ext static;
dcl  error_table_$unimplemented_version
		        fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (32) initial ("uc_ls_dial_request_") internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtins */

dcl (addr, currentsize, null, unspec)
		        builtin;

%page;
/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	code = 0;

	if login_server_dial_request.request_version ^= LS_DIAL_REQUEST_VERSION_1
	then
	     call Abort (error_table_$unimplemented_version,
	     "login_server_dial_request version is ^a, ^a expected.",
	     login_server_dial_request.request_version,
	     LS_DIAL_REQUEST_VERSION_1);

/**** The dial request can be sent to us either with or without user
      identification and authentication.  That is, there may not be any
      user table entry associated with this request when we receive it.
      We can tell this from the handle supplied by the login server.
      If it is 0, then no validation has been performed and there is no
      UTE associated with the request. */

	if login_server_dial_request.initializer_handle = ""b
	then
	     utep = null ();			/* user has not been validated */
	else do;					/* already have a UTE.  Let's check */
	     utep = user_table_mgr_$utep_from_handle (
		login_server_dial_request.initializer_handle);
	     if utep = null ()
	     then
		call Abort (error_table_$id_not_found,
		"Could not locate user table entry for handle ^24.3b.",
		login_server_dial_request.initializer_handle);
	end;

	target_utep = null ();

	call uc_dial_ (utep, (login_server_dial_request.dial_qualifier),
	     (login_server_dial_request.person_id),
	     (login_server_dial_request.project_id),
	     (login_server_dial_request.connection_info.connection_name),
	     login_server_dial_request.connection_info.access_class_range,
	     target_utep, code);
%page;
	if code ^= 0 then do;
	     if utep ^= null ()
	     then
		call uc_logout_ (utep, "dial failed");
	end;
	else do;					/* dial worked.  */
	     if utep ^= null then			/* save owner pid*/
		ute.proc_id = target_utep->ute.proc_id; /* in dial ute.  */

	     ls_response_ptr = P_ls_response_ptr;	/* respond to    */
	     unspec (login_server_dial_response) = ""b;	/* login server  */
	     login_server_dial_response.header.message_type =
		LS_DIAL_RESPONSE;
	     login_server_dial_response.header.version =
		LOGIN_SERVER_DIAL_RESPONSE_VERSION_1;
	     login_server_dial_response.status_code = code;
	     login_server_dial_response.process_id =
		target_utep -> ute.proc_id;
	     call ioa_$rsnnl ("^a.^a.^a",
		login_server_dial_response.process_group_id, (0),
		target_utep -> ute.person, target_utep -> ute.project,
		target_utep -> ute.tag);
	     login_server_dial_response.authorization =
		target_utep -> ute.process_authorization;
	     login_server_dial_response.start_event_channel =
		target_utep -> ute.dial_ev_chn;
	     login_server_dial_response.process_ring =
		target_utep -> ute.initial_ring;
	     P_ls_response_lth = currentsize (login_server_dial_response);
	end;
RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report an error via sys_log_$general and stop execution if a       */
/* nonzero code was given.					       */
/*							       */
/* 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.severity = SL_LOG_SILENT;
	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 RETURN;

     end Abort;

/* format: off */
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;

end uc_ls_dial_request_;




		    uc_ls_disconnect_request_.pl1   07/13/88  1113.4r w 07/13/88  0938.2       53478



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,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-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use sys_log_$general for error reporting.
      B) Correct coding standard violations.
      C) Complete sys_log_ error messages.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_disconnect_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  hangup_ev_message      fixed bin (71) automatic;

/* Entries */

dcl  hcs_$wakeup	        entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  uc_logout_	        entry (ptr, char (*));
dcl  user_table_mgr_$free entry (ptr);
dcl  user_table_mgr_$utep_from_handle entry (bit (72) aligned) returns (ptr);

/* External */

dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$id_not_found fixed bin (35) ext static;

/* Constant */

dcl  HANGUP_EV_MESSAGE      char (8) initial ("hangup") internal static options (constant);
dcl  ME		        char (32) initial ("uc_ls_disconnect_request_") internal static options (constant);

/* Builtin */

dcl (addr, null, unspec)    builtin;
%page;
/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	code = 0;

	utep = user_table_mgr_$utep_from_handle (
	     login_server_disconnect_request.handle);
	if utep = null () then
	     call Abort (SL_LOG_SILENT, error_table_$id_not_found,
		"Could not locate user table entry for handle ^24.3b.",
		login_server_disconnect_request.handle);

	if ute.active = NOW_LOGGED_IN then do;		/* no process yet */
	     call uc_logout_ (utep, "hangup, no process");
	     call user_table_mgr_$free (utep);
	     P_ls_response_lth = 0;
	end;
	else if ute.active = NOW_HAS_PROCESS then do;
	     unspec (hangup_ev_message) = unspec (HANGUP_EV_MESSAGE);
	     ansp = as_data_$ansp;
	     call hcs_$wakeup (anstbl.as_procid, ute.event,
		hangup_ev_message, code);
	     if code ^= 0 then
		call Abort (SL_LOG_BEEP, code,
		"Sending hangup wakeup for ^[*^]^a.^a ^a ^12.3b.",
		(ute.anonymous=1), ute.person, ute.project, ute.tty_name,
		ute.proc_id);
	end;
	else do;
	     call Abort (SL_LOG_BEEP, error_table_$action_not_performed,
		"UTE (^d, ^p in ^a) not logged in (active= ^a, ^d).",
		ute.ute_index, utep, TABLE_NAMES(ute.process_type),
		ACTIVE_VALUES(ute.active), ute.active);
	end;
RETURN:
	P_code = 0;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0 then go to RETURN;

     end Abort;

/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include dialup_values;
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

     end uc_ls_disconnect_request_;




		    uc_ls_list_request_.pl1         07/13/88  1113.4r w 07/13/88  0938.3       63612



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-15,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
  3) change(87-05-16,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Put connection_info.line_type into return structure.
      B) Put ute.initial_ring into the return structure.
      C) Convert to sys_log_$general.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr,insnl */

uc_ls_list_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr
		        ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  i		        fixed bin automatic;

/* Entries */

dcl  get_system_free_area_  entry () returns (ptr);
dcl  uc_list_disconnected_procs_
		        entry (ptr, ptr, ptr);
dcl  user_table_mgr_$utep_from_handle
		        entry (bit (72) aligned) returns (ptr);

/* External */

dcl  error_table_$id_not_found
		        fixed bin (35) ext static;

/* Based */

dcl  system_area	        area based (system_area_ptr);


/* Internal */

dcl  system_area_ptr        ptr int static init (null);


/* Constant */

dcl  ME		        char (19) initial ("uc_ls_list_request_") internal static options (constant);

/* Builtins */

dcl  (addr, currentsize, null, unspec)
		        builtin;


/* Conditions */

dcl  cleanup	        condition;

%page;
/* Program */

	ls_request_ptr = P_ls_request_ptr;
	ls_response_ptr = P_ls_response_ptr;

	code = 0;

	if system_area_ptr = null
	then
	     system_area_ptr = get_system_free_area_ ();
	uc_disconnected_process_list_ptr = null;
	on cleanup
	     begin;
	     if uc_disconnected_process_list_ptr ^= null
	     then free uc_disconnected_process_list in (system_area);
	end;

	utep = user_table_mgr_$utep_from_handle (
	     login_server_list_request.handle);
	if utep = null ()
	then
	     call Abort (error_table_$id_not_found,
		"Could not locate user table entry for handle ^24.3b.",
		login_server_list_request.handle);

	call uc_list_disconnected_procs_ (utep, system_area_ptr,
	     uc_disconnected_process_list_ptr);

	if uc_disconnected_process_list_ptr = null ()
	then
	     login_server_list_response_n_processes = 0;
	else
	     login_server_list_response_n_processes =
		uc_disconnected_process_list.n_disconnected_processes;

	unspec (login_server_list_response) = ""b;
	login_server_list_response.header.message_type = LS_LIST_RESPONSE;
	login_server_list_response.header.version = LOGIN_SERVER_LIST_RESPONSE_VERSION_1;
	login_server_list_response.n_processes = login_server_list_response_n_processes;
	do i = 1 to login_server_list_response_n_processes;
	     utep = uc_disconnected_process_list.process (i).utep;
	     login_server_list_response.creation_time(i) = ute.login_time;
	     login_server_list_response.authorization(i) =
		ute.process_authorization;
	     if ute.initial_ring ^= ute.pdtep->user.default_ring
	     then login_server_list_response.initial_ring(i) =
		ute.initial_ring;
	     else login_server_list_response.initial_ring(i) = 0;
	     login_server_list_response.connection_name(i) = ute.tty_name;

/**** NOTE: We do not maintain the access class range for communication
      channels in the UTE and therefore cannot return this information. */
	     login_server_list_response.access_class_range(i,*) = ""b;
	     login_server_list_response.terminal_type(i) = ute.terminal_type;
	     login_server_list_response.terminal_id(i) = ute.tty_id_code;
	     login_server_list_response.line_type(i) = ute.line_type;
	end;

	if uc_disconnected_process_list_ptr ^= null then do;
	     free uc_disconnected_process_list in (system_area);
	     uc_disconnected_process_list_ptr = null ();
	end;
	P_ls_response_lth = currentsize (login_server_list_response);
RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report error in as log and stop the list operation, returning an   */
/* 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_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	go to RETURN;

     end Abort;

/* format: off */
%page; %include login_server_messages;
%page; %include pdt;

dcl  pdtp ptr automatic init (null);			/* pdt needs it  */
%page; %include sys_log_constants;
%page; %include uc_disc_proc_list;
%page; %include user_attributes; /* not used, but needed by PL/I */
%page; %include user_table_entry;

     end uc_ls_list_request_;




		    uc_ls_logout_request_.pl1       08/04/87  1511.0rew 08/04/87  1511.0       44721



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-27,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-29,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Change references from uc_user_table_mgr_ to user_table_mgr_.
  3) change(87-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use sys_log_$general for error reporting.
      B) Correct coding standard violations.
      C) Complete sys_log_ error messages.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_logout_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/**** This login server request is issued only when a user is in the
      middle of a login dialogue and types "logout".  It is used to
      notify the AS to clean up the ute entry for the user. */

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  utep		        ptr automatic;

/* Entries */

dcl  user_table_mgr_$free entry (ptr);
dcl  user_table_mgr_$utep_from_handle entry (bit (72) aligned)
		        returns (ptr);
dcl  uc_logout_	        entry (ptr, char (*));

/* External */

dcl  error_table_$id_not_found fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (21) initial ("uc_ls_logout_request_") internal static options (constant);

/* Builtins */

dcl (addr, null)	        builtin;
%page;
/* Program */

	ls_request_ptr = P_ls_request_ptr;

	code = 0;

	utep = user_table_mgr_$utep_from_handle (
	     login_server_logout_request.handle);
	if utep = null () then
	     call Abort (error_table_$id_not_found,
		"Could not locate user table entry for handle ^24.3b.",
		login_server_logout_request.handle);

/**** Log the user out, if he is logged in. */

	call uc_logout_ (utep, "logout, no process");

/**** Free the user table entry. */

	call user_table_mgr_$free (utep);

/**** The login server will not expect any response */

	P_ls_response_lth = 0;
RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0 then go to RETURN;

     end Abort;

/* format: off */
%page; %include ls_request_server_info;
%page; %include login_server_messages;
%page; %include sys_log_constants;

end uc_ls_logout_request_;




		    uc_ls_new_proc_request_.pl1     07/13/88  1113.4r w 07/13/88  0938.3       48393



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
  3) change(87-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use sys_log_$general to report errors.
      B) Correct coding standard violations.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_new_proc_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;

/* Entries */

dcl  asu_$send_term_signal  entry (ptr, fixed bin) returns (bit (1) aligned);
dcl  dpg_		        entry (ptr, char (*));
dcl  uc_setup_process_connect_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, ptr, fixed bin (35));

/* Constant */

dcl  ME		        char (23) initial ("uc_ls_new_proc_request_") internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtins */

dcl (addr, null)	        builtin;

%page;
/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	code = 0;

	call uc_setup_process_connect_ (P_ls_request_server_info_ptr,
	     P_ls_request_ptr, P_ls_request_lth, P_ls_response_ptr,
	     P_ls_response_lth, P_ls_ipc_reply_ptr, utep, code);
	if code ^= 0 then
	     call Abort (code,
	     "Issuing new_proc for ^a.^a ^a",
	     login_server_process_request.person_id,
	     login_server_process_request.project_id,
	     login_server_process_request.connection_name);

/**** Tell the request server not to send a reply for this request, yet. */

	P_ls_ipc_reply_ptr -> ls_reply_message.flags.do_not_reply = TRUE;
	P_ls_response_lth = 0;

	ute.logout_type = "newp";
	ute.destroy_flag = WAIT_NEW_PROC_REQUEST;

	if login_server_process_request.other_flags.immediate then
	     call dpg_ (utep, "new_proc immediate");
	else if ^asu_$send_term_signal (utep, PT_NEW_PROC_REQUEST) then
	     call dpg_ (utep, "new_proc");
	else ;					/* sent trm_ signal; go away until response comes in */

RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* 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_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0 then go to RETURN;

     end Abort;

/* format: off */
%page; %include dialup_values;
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;

end uc_ls_new_proc_request_;




		    uc_ls_operator_request_.pl1     07/13/88  1113.4r w 07/13/88  0938.3       88497



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-08,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-08,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-08,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Logout user (updating who_tab as well) if operator login denied by
         mc_commands_$mc_login.  Also, destroy the user table entry.
      B) Null login_server_operator_response.process_group_id when operator
         login fails.
      C) Use sys_log_$general to report errors.
      D) Null login_server_operator_request.person_id, project_id,
         virtual_channel for non-I&A logins, rather than depending upon the
         login server to do this.
      E) Updated for change to user_table_entry.incl.pl1.
  3) change(87-06-11,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Change calling sequence of mc_commands_$mc_login to pass utep, so
         Initializer process_id can be filled in after the channel has been
         added to mc_anstbl.  This allows operator to drop the channel rather
         than accepting it.
  4) change(87-06-26,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Pass connection_info.access_class_range to mc_commands_$mc_login for
         use in the operator login audit message.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr,insnl */

uc_ls_operator_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr
		        ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  ls_termination_event_channel
		        fixed bin (71) automatic;

/* Entries */

dcl  mc_commands_$mc_login  entry (char (*), char (*), ptr, char (*), (2) bit (72) aligned, bit (36) aligned,
		        fixed bin (71), fixed bin (71), bit (72) aligned, fixed bin (35));
dcl  uc_logout_	        entry (ptr, char (*));
dcl  user_table_mgr_$free
		        entry (ptr);
dcl  user_table_mgr_$utep_from_handle
		        entry (bit (72) aligned) returns (ptr);

/* External */

dcl  error_table_$bad_arg   fixed bin (35) ext static;
dcl  error_table_$id_not_found
		        fixed bin (35) ext static;
dcl  error_table_$unimplemented_version
		        fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (23) initial ("uc_ls_operator_request_") internal static options (constant);

dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Builtin */

dcl  (addr, currentsize, null, unspec)
		        builtin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


/* Program */

	ls_request_ptr = P_ls_request_ptr;
	ls_response_ptr = P_ls_response_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	ls_request_server_info_ptr = P_ls_request_server_info_ptr;

	code = 0;

	if login_server_operator_request.request_version ^=
	     LOGIN_SERVER_OPERATOR_REQUEST_VERSION_1
	then call Abort (error_table_$unimplemented_version,
		"Version of login_server_operator_request is ^a, ^a expected.",
		login_server_operator_request.request_version,
		LOGIN_SERVER_OPERATOR_REQUEST_VERSION_1);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* The operator request can be sent to us either with or without user	       */
/* identification and authentication.  This occurs when when the user types  */
/* "d system" without specifying "-user Personid.Projectid".  In this case,  */
/* there will not be any user table entry associated with this request.  We  */
/* can tell this from the handle supplied by the login server.  If it is 0,  */
/* then no validation has been performed and there is no UTE associated with */
/* the request.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if login_server_operator_request.initializer_handle = ""b
	then do;
	     utep = null ();			/* no I&A */
	     login_server_operator_request.person_id,
		login_server_operator_request.project_id,
		login_server_operator_request.virtual_channel = "";
	end;
	else do;
	     utep = user_table_mgr_$utep_from_handle
		(login_server_operator_request.initializer_handle);
	     if utep = null ()
	     then call Abort (error_table_$id_not_found,
		     "Could not locate user table entry for handle ^24.3b.",
		     login_server_operator_request.initializer_handle);
	end;

	if utep ^= null ()
	then if login_server_operator_request.person_id ^= ute.person
		| login_server_operator_request.project_id ^= ute.project
	     then call Abort (error_table_$bad_arg,
		     "Person.project in operator request (^a.^a) do not match UTE (^a.^a)",
		     login_server_operator_request.person_id,
		     login_server_operator_request.project_id,
		     ute.person, ute.project);

	if utep ^= null ()
	then ls_termination_event_channel =
		ute.login_server_info.termination_event_channel;
	else ls_termination_event_channel =
		login_server_operator_request.terminate_event_channel;

	call mc_commands_$mc_login (
	     (login_server_operator_request.connection_info.connection_name),
	     (login_server_operator_request.person_id), utep,
	     (login_server_operator_request.virtual_channel),
	     login_server_operator_request.connection_info.access_class_range,
	     ls_request_server_info.request_info.sender_process_id,
	     ls_termination_event_channel,
	     login_server_operator_request.header.reply_event_channel,
	     login_server_operator_request.header.reply_handle, code);

/**** If the message coordinator said this was ok, then we don't send the
      response.  We let the MC do it. */

	if code = 0
	then ls_reply_message.flags.do_not_reply = TRUE;
	else do;
	     call Fill_response_structure ();
	     code = 0;
	     if utep ^= null
	     then do;
		call uc_logout_ (utep, "DENIED: login -operator");
		call user_table_mgr_$free (utep);
	     end;
	end;

RETURN:
	P_code = code;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report an error via sys_log_$general and stop execution if a       */
/* nonzero code was given.					       */
/*							       */
/* 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.severity = SL_LOG_SILENT;
	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 RETURN;

     end Abort;

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


Fill_response_structure:
     procedure;

	unspec (login_server_operator_response) = ""b;
	login_server_operator_response.header.message_type =
	     LS_OPERATOR_RESPONSE;
	login_server_operator_response.header.version =
	     LOGIN_SERVER_OPERATOR_RESPONSE_VERSION_1;
	login_server_operator_response.status_code = code;
	login_server_operator_response.process_group_id = "";
	P_ls_response_lth = currentsize (login_server_operator_response);

     end Fill_response_structure;

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

/* format: off */
 %include login_server_messages;
 %include ls_request_server_info;
 %include sys_log_constants;
 %include user_attributes; /* not used, but needed by PL/I */
 %include user_table_entry;

     end uc_ls_operator_request_;




		    uc_ls_process_request_.pl1      08/04/87  1511.0rew 08/04/87  1511.0       53919



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



/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-24,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-23,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-24,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Upgrade to use sys_log_$general to report errors.
      B) Handle enter and enterp preaccess commands.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_process_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  abort_label	        label automatic;
dcl  code		        fixed bin (35) automatic;
dcl  entry_to_call	        entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, fixed bin (35)) variable;

/* Entries */

dcl  uc_ls_create_request_  entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, fixed bin (35));
dcl  uc_ls_destroy_request_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, fixed bin (35));
dcl  uc_ls_connect_request_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, fixed bin (35));
dcl  uc_ls_new_proc_request_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18), ptr, fixed bin (35));

/* External */

dcl  error_table_$bad_arg   fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (22) initial ("uc_ls_process_request_") internal static options (constant);

/* Builtins */

dcl  addr		        builtin;

%page;
/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	code = 0;

	abort_label = RETURN;

	if login_server_process_request.header.request_version ^=
	     LS_PROCESS_REQUEST_VERSION_1 then
	     call Abort (SL_LOG_SILENT, code,
		"login_server_process_request version is ^a, should be ^a.",
		login_server_process_request.header.request_version,
		LS_PROCESS_REQUEST_VERSION_1);

	if login_server_process_request.command_type = LOGIN_REQ then
	     entry_to_call = uc_ls_create_request_;
	else if login_server_process_request.command_type = CREATE_REQ then
	     entry_to_call = uc_ls_create_request_;
	else if login_server_process_request.command_type = DESTROY_REQ then
	     entry_to_call = uc_ls_destroy_request_;
	else if login_server_process_request.command_type = CONNECT_REQ then
	     entry_to_call = uc_ls_connect_request_;
	else if login_server_process_request.command_type = NEW_PROC_REQ then
	     entry_to_call = uc_ls_new_proc_request_;
	else if login_server_process_request.command_type = ENTER_REQ then
	     entry_to_call = uc_ls_create_request_;
	else if login_server_process_request.command_type = ENTERP_REQ then
	     entry_to_call = uc_ls_create_request_;
	else call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		"command_type is invalid (^d).",
		login_server_process_request.command_type);

/**** Dispatch on subrequest */

	call entry_to_call (P_ls_request_server_info_ptr, P_ls_request_ptr,
	     P_ls_request_lth, P_ls_response_ptr, P_ls_response_lth,
	     P_ls_ipc_reply_ptr, code);

RETURN:
	P_code = code;
	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report an error via sys_log_$general and stop execution if a       */
/* nonzero code was given.					       */
/*							       */
/* 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;

/* format: off */
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include sys_log_constants;

end uc_ls_process_request_;




		    uc_ls_rq_server_wakeup_.pl1     08/04/87  1511.0rew 08/04/87  1511.0      133182



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-08-05,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-16,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations.
      B) Integrate Swenson's later changes into the module.
      C) Use LS_REQUEST_TYPES and LS_RESPONSE_TYPES arrays to improve trace
         messages.
      D) Convert to sys_log_$general for error and trace messages.
      E) Upgraded for change to answer_table.incl.pl1.
  3) change(87-05-18,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Remove procedures for sending a login server response from this
         program.  Centralize this function in uc_send_ls_response_.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_rq_server_wakeup_:
     procedure (P_event_call_info_ptr);

/* Parameters */

dcl  P_event_call_info_ptr  ptr parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  ls_data_reply_lth      fixed bin (18) automatic;
dcl  ls_data_reply_ptr      ptr automatic;
dcl  ls_request_lth	        fixed bin (18) automatic;
dcl  1 mmi	        aligned like mseg_message_info automatic;
dcl  ms_index	        fixed bin automatic;
dcl  request_type	        fixed bin automatic;
dcl  response_type	        fixed bin automatic;

/* External */

dcl  as_error_table_$dialup_error fixed bin (35) ext static;
dcl  error_table_$bad_arg   fixed bin (35) external;
dcl  error_table_$no_message fixed bin (35) external;
dcl  error_table_$out_of_sequence fixed bin (35) external;
dcl  error_table_$unexpected_condition fixed bin (35) external;
dcl  error_table_$unimplemented_version fixed bin (35) external;

/* Entries */

dcl  as_any_other_handler_$no_cleanup entry (char (*), label);
dcl  get_system_free_area_  entry returns (pointer);
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  pathname_	        entry (char (*), char (*)) returns (char (168));
dcl  (uc_ls_validate_request_,
     uc_ls_process_request_,
     uc_ls_list_request_,
     uc_ls_dial_request_,
     uc_ls_disconnect_request_,
     uc_ls_logout_request_,
     uc_ls_operator_request_)
		        entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18),
		        bit (72) aligned, fixed bin (35));
dcl  uc_send_ls_response_   entry (ptr, fixed bin(18), bit(36) aligned,
		        bit(72) aligned, fixed bin(71), ptr,
		        char(32) aligned, fixed bin(35), fixed bin(35));

/* Builtin */

dcl  (addr, currentsize, divide, hbound, lbound, null, rtrim, unspec) builtin;

/* Internal Static */

dcl  system_area_ptr        ptr int static init (null);
dcl  trace_flag	        bit (1) aligned initial ("0"b) internal static;

/* Constant */

dcl  FALSE	        bit (1) initial ("0"b) internal static options (constant);
dcl  ME		        char (23) initial ("uc_ls_rq_server_wakeup_") internal static
		        options (constant);
dcl  TRUE		        bit (1) initial ("1"b) internal static options (constant);

/* Based */

dcl  system_area	        area based (system_area_ptr);


/* Conditions */

dcl  any_other	        condition;
dcl  cleanup	        condition;
%page;
/* Program */

	event_call_info_ptr = P_event_call_info_ptr;
	ls_request_server_info_ptr = event_call_info.data_ptr;

	if ls_request_server_info_ptr = null () then
	     call Abort (SL_LOG_BEEP, error_table_$out_of_sequence,
		MAIN_RETURN, "Wakeup with null ptr to sectest_server_info.");

	if ^ls_request_server_info.flags.initialized then
	     call Abort (SL_LOG_BEEP, error_table_$out_of_sequence,
		MAIN_RETURN,
		"Wakeup with ls_request_server_info not initialized.");

/**** Leave a record that a login server request has been received.  This
      flag is used by dial_ctl_ to decide whether to call
      uc_cleanup_network_dials_. */

	ansp = as_data_$ansp;
	if anstbl.login_server_present = FALSE then
	     anstbl.login_server_present = TRUE;

	ms_index = ls_request_server_info.request_ms.index;
	if ms_index = 0 then
	     call Abort (SL_LOG_BEEP, error_table_$out_of_sequence,
		MAIN_RETURN, "Request message segment not initialized yet.");

	unspec (mmi) = ""b;
	mmi.version = MSEG_MESSAGE_INFO_V1;
	mmi.message_code = MSEG_READ_FIRST;
	mmi.ms_ptr = null ();

	if system_area_ptr = null then
	     system_area_ptr = get_system_free_area_ ();

	on cleanup
	     call Clean_Up ();

	call Process_Messages ();
MAIN_RETURN:
	return;
%page;
trace_on:
     entry ();

	trace_flag = TRUE;
	return;


trace_off:
     entry ();

	trace_flag = FALSE;
	return;
%page;
Process_Messages:
     procedure ();

dcl  action	        fixed bin;
dcl  message_count	        fixed bin;

dcl  (PROCESS	        initial (1),
     REJECT	        initial (2)) fixed bin internal static options (constant);

	do while ("1"b);
	     call message_segment_$read_message_index (ms_index,
		addr (system_area), addr (mmi), code);
	     if code = error_table_$no_message then return;
	     if code ^= 0 then
		call Abort (SL_LOG_BEEP, code, MAIN_RETURN,
		     "Error reading message from message segment.");

	     action = Examine_Message ();

	     if action = PROCESS then
		call Process_The_Message ();

	     call Delete_The_Message ();

	     if mmi.ms_ptr ^= null () then begin;

declare  msg		  bit (mmi.ms_len) aligned based (mmi.ms_ptr);

		free msg in (system_area);
		mmi.ms_ptr = null ();
	     end;

	     call message_segment_$get_message_count_index (ms_index,
		message_count, code);
	     if code ^= 0 then
		call Abort (SL_LOG_BEEP, code, MAIN_RETURN,
		     "Could not get message count from message segment ^a.",
		     pathname_ (ls_request_server_info.request_ms.dirname,
		     ls_request_server_info.request_ms.entryname));

	     if message_count = 0 then
		return;
	end;
%page;
Examine_Message:
	procedure () returns (fixed bin);

	     ls_request_ptr = mmi.ms_ptr;
	     ls_request_lth = divide (mmi.ms_len, 36, 18);

	     if ls_request_lth < (currentsize (ls_request_header)) then
		call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		     REJECT_MESSAGE,
		     "Size of request from ^a too small.  Got ^d; expected at least ^d.",
		     mmi.sender_id, ls_request_lth,
		     currentsize (ls_request_header));
	     else if ls_request_header.header_version ^=
		LS_REQUEST_HEADER_VERSION_1 then
		call Abort (SL_LOG_SILENT,
		     error_table_$unimplemented_version, REJECT_MESSAGE,
		     "Invalid version (^a) in request from ^a.",
		     ls_request_header.header_version, mmi.sender_id);
	     else do;
		request_type = ls_request_header.request_type;
		if lbound (LS_REQUEST_TYPES, 1) <= request_type &
		     request_type <= hbound (LS_REQUEST_TYPES, 1)
		then code = 0;
		else call Abort (SL_LOG_SILENT, error_table_$bad_arg,
			REJECT_MESSAGE, "Invalid request type ^d from ^a.",
			request_type, mmi.sender_id);
	     end;

	     return (PROCESS);

REJECT_MESSAGE:
	     return (REJECT);

	end Examine_Message;
%page;
Process_The_Message:
	procedure ();

dcl  1 auto_ls_reply_message aligned like ls_reply_message automatic;
dcl  code		        fixed bin (35) automatic;
dcl  entry_to_call	        entry (ptr, ptr, fixed bin (18), ptr, fixed bin (18),
		        ptr, fixed bin (35)) variable;

	     if trace_flag then
		call Trace ("Received ^a request from ^a.",
		     LS_REQUEST_TYPES (request_type), mmi.sender_id);

	     if request_type = LS_VALIDATE_REQUEST then
		entry_to_call = uc_ls_validate_request_;
	     else if request_type = LS_PROCESS_REQUEST then
		entry_to_call = uc_ls_process_request_;
	     else if request_type = LS_LIST_REQUEST then
		entry_to_call = uc_ls_list_request_;
	     else if request_type = LS_DIAL_REQUEST then
		entry_to_call = uc_ls_dial_request_;
	     else if request_type = LS_DISCONNECT_REQUEST then
		entry_to_call = uc_ls_disconnect_request_;
	     else if request_type = LS_LOGOUT_REQUEST then
		entry_to_call = uc_ls_logout_request_;
	     else if request_type = LS_OPERATOR_REQUEST then
		entry_to_call = uc_ls_operator_request_;
	     else call Abort (SL_LOG_SILENT, error_table_$bad_arg,
		     ABORT_REQUEST_NO_REPLY,
		     "Invalid request type ^d specified.", request_type);

	     ls_reply_message_ptr = addr (auto_ls_reply_message);
	     unspec (ls_reply_message) = ""b;

	     ls_data_reply_ptr = ls_request_server_info.reply_ptr;
	     ls_data_reply_lth = 0;

	     ls_request_server_info.request_info.sender_process_id =
		mmi.sender_process_id;

	     on any_other begin;
		revert any_other;
		code = as_error_table_$dialup_error;
		unspec (ls_reply_message) = ""b;
		ls_reply_message.code = code;
		ls_reply_message.flags.do_not_reply = FALSE;
		call Abort (SL_LOG_BEEP, error_table_$unexpected_condition,
		     TAKE_AS_DUMP,
		     "Processing login server ""^a"" request from ^a.",
		     LS_REQUEST_TYPES (request_type), mmi.sender_id);
TAKE_AS_DUMP:	call as_any_other_handler_$no_cleanup (ME, ABORT_REQUEST);
	     end;

	     call entry_to_call (ls_request_server_info_ptr,
		ls_request_ptr, ls_request_lth,
		ls_data_reply_ptr, ls_data_reply_lth,
		ls_reply_message_ptr, code);

	     revert any_other;

ABORT_REQUEST:
	     if ls_data_reply_lth > 0 then
		call Test_Data_Reply ();

	     if trace_flag then
		call Trace (
		     "Processed ^a request from ^a.  ^[No reply.^;Reply^[ with ^a response.^]^]",
		     LS_REQUEST_TYPES (request_type), mmi.sender_id,
		     ls_reply_message.do_not_reply, ls_data_reply_lth > 0,
		     LS_RESPONSE_TYPES (response_type));

	     if ^ls_reply_message.do_not_reply then
		call uc_send_ls_response_ (ls_data_reply_ptr,
		ls_data_reply_lth, mmi.sender_process_id,
		ls_request_header.reply_handle,
		ls_request_header.reply_event_channel,
		addr(ls_reply_message), ls_request_header.connection_name,
		code, code);
	     else ;				/* we don't want to send anything to LS (yet). */

ABORT_REQUEST_NO_REPLY:
	     return;
%page;
Test_Data_Reply:
     procedure ();

	ls_response_ptr = ls_data_reply_ptr;
	response_type = login_server_response_header.message_type;
	if lbound (LS_RESPONSE_TYPES, 1) <= response_type &
	     response_type <= hbound (LS_RESPONSE_TYPES, 1) then ;
	else response_type = LS_UNKNOWN_RESPONSE;

	end Test_Data_Reply;
     end Process_The_Message;
end Process_Messages;
%page;
Clean_Up:
     procedure ();

declare  msg		  bit (mmi.ms_len) aligned
			  based (mmi.ms_ptr);
	if mmi.ms_ptr ^= null () then
	     free msg in (system_area);

     end Clean_Up;
%page;
Delete_The_Message:
     procedure ();

	call message_segment_$delete_index (ms_index, mmi.ms_id, code);
	if code ^= 0 then
	     call Abort (SL_LOG_SILENT, code, DELETE_FAILED,
		"Could not delete message ^.3b for ^a.", mmi.ms_id,
		mmi.sender_id);
	else mmi.ms_id = ""b;			/* clear out since no longer valid */

DELETE_FAILED:
     end Delete_The_Message;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  report errors via sys_log_$general.			       */
/*							       */
/* Syntax:  call Abort (severity, code, error_return_label, ioa_ctl, args);  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Abort:
     procedure options (variable);

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_$general       entry (ptr);

dcl  abort_label_ptr        pointer automatic;
dcl  abort_label	        label based (abort_label_ptr);

	sl_info = sl_info_sev_code_label_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 do;
	     call cu_$arg_ptr_rel (3, abort_label_ptr, 0, 0,
		sl_info.arg_list_ptr);
	     go to abort_label;
	end;

     end Abort;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Trace:  trace events via sys_log_$general.			       */
/*							       */
/* Syntax:  call Trace (ioa_ctl, args);				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Trace:
     procedure options (variable);

dcl  cu_$arg_list_ptr       entry returns (ptr);
dcl  sys_log_$general       entry (ptr);

	sl_info = sl_info_msg;
	sl_info.caller = rtrim (ME) || " (trace)";
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));

     end Trace;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include condition_info;
%page; %include condition_info_header;
%page; %include event_call_info;
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include mseg_message_info;
%page; %include sys_log_constants;
%page; %include user_table_header;

end uc_ls_rq_server_wakeup_;




		    uc_ls_validate_request_.pl1     07/13/88  1113.4r w 07/13/88  0938.3      126099



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-07,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-24,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-07,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct problem with enter (anonymous no password) logins.
      B) Change wakeup priority for ute.event to coincide with that used by
         dialup_.
      C) Reordered statements to reflect changes to user_table_entry.incl.pl1
         and user_table_entry.incl.pl1 and login_server_validate_response
         structure.
      D) Improved sys_log_ messages.
      E) Added login_server_validate_response.last_incorrect_password.time.
      F) Use login_server_validate_request.connection_info.line_type. (dsa 123)
  3) change(87-05-11,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use named constants from dialup_values.incl.pl1 for ute.tag values.
  4) change(87-05-13,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Set ute.line_type from login_server_validate_request.line_type.
      B) Remove use of uc_validate_info.line_type.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_ls_validate_request_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_reply_data_ptr, P_ls_reply_data_lth,
	P_ls_ipc_reply_ptr, P_code);

/**** TBS: Add auditing of errors. */

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_reply_data_ptr    ptr parameter;
dcl  P_ls_reply_data_lth    fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  abort_label	        label automatic;
dcl  1 auto_uc_validate_info aligned like uc_validate_info automatic;
dcl  code		        fixed bin (35) automatic;
dcl  ip		        ptr automatic;
dcl  validate_code	        fixed bin (35) automatic;

/* Entries */

dcl  as_any_other_handler_$no_cleanup entry (char (*), label);
dcl  asu_$setup_login_server_handle entry (ptr);
dcl  ipc_$decl_event_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  uc_login_	        entry (ptr, ptr, fixed bin (35));
dcl  uc_proc_term_handler_  entry (ptr);
dcl  user_table_mgr_$allocate entry (fixed bin) returns (ptr);
dcl  user_table_mgr_$free entry (ptr);

/* External */

dcl  as_error_table_$dialup_error fixed bin (35) ext static;
dcl  as_error_table_$tty_no_room fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (23) initial ("uc_ls_validate_request_") internal static options (constant);

dcl  (ANONYMOUS	        initial (1),
     NOT_ANONYMOUS	        initial (0)) fixed bin internal static options (constant);

dcl  (TRUE	        initial ("1"b),
     FALSE	        initial ("0"b)) bit (1) aligned internal static options (constant);

/* Conditions */

dcl  any_other	        condition;

/* Builtin */

dcl  (addr, currentsize, null, substr, unspec)
		        builtin;
%page;
/* Program */

	utep = null ();
	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;

	abort_label = ERROR_RETURN;
	code = 0;

	on any_other
	     call as_any_other_handler_$no_cleanup (ME, FAULT_LABEL);

	if login_server_validate_request.header.request_version ^=
	     LS_VALIDATE_REQUEST_VERSION_1 then
	     call Abort (SL_LOG_SILENT, error_table_$unimplemented_version,
		"Expected login_server_validate_request version ^a, received ^a.",
		LS_VALIDATE_REQUEST_VERSION_1, login_server_validate_request.header.request_version);

	utep = user_table_mgr_$allocate (PT_INTERACTIVE);
	if utep = null then
	     call Abort (SL_LOG, as_error_table_$tty_no_room,
		"The answer table is full.");
	call ipc_$decl_event_call_chn (ute.event, uc_proc_term_handler_,
	     utep, INT_LOGIN_PRIO, code);
	if code ^= 0 then
	     call Abort (SL_LOG, code,
		"Setting event call handler for user table entry (^p).", utep);


/**** Initialize validate_info and reply_message structures */

	unspec (ls_reply_message) = ""b;

	uc_validate_info_ptr = addr (auto_uc_validate_info);
	unspec (uc_validate_info) = ""b;


/**** Fill in ute from validate request info */

	ute.person = login_server_validate_request.person_id;
	ute.project = login_server_validate_request.project_id;
	if login_server_validate_request.network_connection_type =
	     NETWORK_CONNECTION_DSA_FILE_TRANSFER then
	     ute.tag = TAG_UFT;
	else
	     ute.tag = TAG_INTERACTIVE;

	if login_server_validate_request.flags.anonymous then do;
	     ute.anonymous = ANONYMOUS;
	     uc_validate_info.flags.check_anonymous_password = TRUE;
	end;
	else if login_server_validate_request.flags.anon_no_password then do;
	     ute.anonymous = ANONYMOUS;
	     uc_validate_info.flags.check_anonymous_password = FALSE;
	end;
	else ute.anonymous = NOT_ANONYMOUS;

	ute.network_connection_type =
	     login_server_validate_request.network_connection_type;
	ute.tty_name =
	     login_server_validate_request.connection_info.connection_name;
	ute.tty_id_code =
	     login_server_validate_request.connection_info.terminal_id;
	ute.terminal_type =
	     login_server_validate_request.connection_info.terminal_type;
	ute.line_type =
	     login_server_validate_request.connection_info.line_type;

	if login_server_validate_request.flags.auth_given then do;
	     ute.login_flags.auth_given = TRUE;
	     ute.process_authorization =
		login_server_validate_request.authorization;
	end;

	ute.login_flags.cpw =
	     login_server_validate_request.flags.change_password;
	ute.login_flags.generate_pw =
	     login_server_validate_request.flags.gpw;

	ute.login_flags.cdp =
	     login_server_validate_request.flags.change_default_proj;
	ute.login_flags.cda =
	     login_server_validate_request.flags.change_default_auth;

	if ute.login_flags.cpw then do;
	     uc_validate_info.password =
		login_server_validate_request.new_password;
	     ute.old_password =
		login_server_validate_request.current_password;
	end;
	else uc_validate_info.password =
		login_server_validate_request.current_password;

/**** The operator flag indicates that the user wants to log in as an
      operator.  This is the functional replacement of "dial system.". */

	ute.login_flags.operator = login_server_validate_request.flags.operator;

	ute.login_server_info.his_handle =
	     login_server_validate_request.header.reply_handle;
	ute.login_server_info.process_id =
	     ls_request_server_info.request_info.sender_process_id;
	ute.login_server_info.response_event_channel =
	     login_server_validate_request.header.reply_event_channel;
	ute.login_server_info.termination_event_channel =
	     login_server_validate_request.terminate_event_channel;


/**** Finish filling in uc_validate_info */

	uc_validate_info.channel_info.access_class_range (*) =
	     login_server_validate_request.connection_info.access_class_range;

/**** TBS: At present, there is no check to see if a user, undergoing I&A,
      has access to use the particular channel on which he is attempting to
      log in.  This really should be done by the AS since we can reject the
      login as we do for MCS channels if the user lacks appropriate access.
      For the time being, however, we perform no discretionary access checking
      on the login channel name. */

	uc_validate_info.flags.check_channel_access = FALSE;


/**** Clear out message buffer used to hold login messages for the user */

	as_data_$ls_message_buffer_cur_lth = 0;

	call uc_login_ (uc_validate_info_ptr, utep, validate_code);

/**** Validate_code gets placed in the response record. */

	if validate_code = 0 then
	     call asu_$setup_login_server_handle (utep);

	call Setup_Response ();

	if validate_code ^= 0 then
	     goto ERROR_RETURN;
	else
	     goto RETURN;
FAULT_LABEL:
	code = as_error_table_$dialup_error;
ERROR_RETURN:
	if utep ^= null () then
	     call user_table_mgr_$free (utep);
RETURN:
	P_code = code;
	return;
%page;
Setup_Response:
     procedure ();

	ls_response_ptr = P_ls_reply_data_ptr;
	unspec (login_server_validate_response) = ""b;

	login_server_validate_response.header.message_type =
	     LS_VALIDATE_RESPONSE;
	login_server_validate_response.header.header_pad = ""b;
	login_server_validate_response.header.version =
	     LS_VALIDATE_RESPONSE_VERSION_1;

	login_server_validate_response.handle =
	     ute.login_server_info.our_handle;
	login_server_validate_response.authorization =
	     ute.process_authorization;
	login_server_validate_response.authorization_range =
	     ute.process_authorization_range;
	login_server_validate_response.status_code = validate_code;
	login_server_validate_response.person_id =
	     substr (ute.person, 1, 22);
	login_server_validate_response.project_id =
	     substr (ute.project, 1, 9);
	login_server_validate_response.n_disconnected_processes =
	     uc_validate_info.number_disconnected_processes;

	login_server_validate_response.previous_login_info.time =
	     uc_validate_info.last_login_info.time;
	login_server_validate_response.previous_login_info.terminal_type =
	     uc_validate_info.last_login_info.terminal_type;
	login_server_validate_response.previous_login_info.terminal_id =
	     uc_validate_info.last_login_info.terminal_id;

	login_server_validate_response.incorrect_passwords =
	     uc_validate_info.last_bad_pw_info.number;
	login_server_validate_response.last_incorrect_password.terminal_type =
	     uc_validate_info.last_bad_pw_info.terminal_type;
	login_server_validate_response.last_incorrect_password.terminal_id =
	     uc_validate_info.last_bad_pw_info.terminal_id;

	if ute.login_result = 1			/* do not allow retry */ then
	     login_server_validate_response.flags.disconnect = TRUE;
	else login_server_validate_response.flags.disconnect = FALSE;
	login_server_validate_response.flags.password_changed =
	     uc_validate_info.output_info.flags.changed_password;
	login_server_validate_response.flags.default_auth_changed =
	     uc_validate_info.output_info.flags.default_authorization_changed;
	login_server_validate_response.flags.default_proj_changed =
	     uc_validate_info.output_info.flags.changed_default_project;
	login_server_validate_response.flags.password_expired =
	     uc_validate_info.output_info.flags.password_expired;
	login_server_validate_response.flags.password_unused_too_long =
	     uc_validate_info.output_info.flags.password_unused_too_long;

	ip = as_data_$rs_ptrs (0);
	if login_server_validate_response.flags.password_unused_too_long then
	     login_server_validate_response.password_interval =
		installation_parms.password_expiration_interval;
	else if login_server_validate_response.flags.password_expired then
	     login_server_validate_response.password_interval =
		installation_parms.password_change_interval;

	login_server_validate_response.flags.pad = ""b;

	P_ls_reply_data_lth = currentsize (login_server_validate_response);
	return;
     end Setup_Response;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report an error via sys_log_$general and stop execution if a       */
/* nonzero code was given.					       */
/*							       */
/* 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;

/* format: off */
%page; %include as_data_;
%page; %include as_wakeup_priorities;
%page; %include dialup_values;
%page; %include installation_parms;
%page; %include line_types;
%page; %include login_server_messages;
%page; %include ls_request_server_info;
%page; %include sys_log_constants;
%page; %include uc_ls_handle;
%page; %include uc_validate_info;
%page; %include user_attributes;
%page; %include user_table_entry;

end uc_ls_validate_request_;




		    uc_proc_term_handler_.pl1       07/13/88  1113.4r w 07/13/88  0938.3      453870



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(85-08-01,Swenson), approve(87-07-14,MCR7737),
     audit(87-05-18,GDixon), install(87-08-04,MR12.1-1055):
     Initially coded.
  2) change(86-04-09,Herbst), approve(87-07-14,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Changed Disconnect_Process proc to set ute.disconnection_rel_minutes.
  3) change(87-03-03,Brunelle), approve(87-07-14,MCR7737),
     audit(87-07-30,GDixon), install(87-08-04,MR12.1-1055):
     Added code to handle inacrcvd (inactivity msg received and processed)
     signal (signal type 12).  This reschedules the bump timer scheduled for
     the user to installation_parms.warning_time from the receipt of the
     signal by calling asu_$reschedule_bump_timer.
  4) change(87-04-27,GDixon), approve(87-07-14,MCR7737),
     audit(87-07-30,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-05-17,GDixon), approve(87-07-14,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use automatic response structures rather than based storage.
      B) Use constants to set/test ute.preempted.
      C) Use sys_log_$general to report errors.
      D) Allow operator requests to bump/detach a logged in user with no
         process.
      E) Use new uc_send_ls_response_ calling sequence.
  6) change(87-05-18,Parisek), approve(87-07-14,MCR7690),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Added call to remove MC tty when bumping a logged in user with no process
     (User logged in as operator).
  7) change(87-05-18,Brunelle), approve(87-07-14,MCR7737),
     audit(87-07-30,GDixon), install(87-08-04,MR12.1-1055):
     Added call to set anstbl.current_time which was forgotten.
  8) change(87-05-29,GDixon), approve(87-07-14,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) When bumping a logged-in, no-process UTE, hold the user connection
         rather than dropping it.
  9) change(87-06-02,GDixon), approve(87-07-14,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Correct error in ioa_ control string.
 10) change(87-06-09,GDixon), approve(87-07-14,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Include process ID and group ID in
         login_server_termination_response.  For dialed terminals having a
         UTE, the process ID of the target process has been placed in their
         UTE by uc_ls_dial_request_ or mc_commands_$mc_login.
 11) change(87-07-14,Parisek), approve(87-07-14,MCR7644),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Added code for handling a user "disconnect" command.
 12) change(87-07-15,GDixon), approve(87-07-15,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Audit process terminations via as_access_audit_$process.
 13) change(87-07-30,GDixon), approve(87-07-30,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct arguments in several error messages.
      B) When user unbumped too late, give him a new process just as dialup_
         does.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr,insnl */

uc_proc_term_handler_:
     procedure (P_event_call_info_ptr);

/* Parameters */

dcl  P_event_call_info_ptr  ptr parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;
dcl  destroy_index	        fixed bin (17) automatic;
dcl  ip		        ptr automatic;
dcl  metering_enabled       bit (1) aligned automatic;
dcl  pdtep	        ptr automatic;
dcl  saved_destroy_flag     fixed bin automatic;
dcl  signal_left_half       char (4) automatic;
dcl  signal_string	        char (8) automatic;
dcl  wakeup_from	        fixed bin automatic;
dcl  whoptr	        ptr automatic;

/* Automatic Structures */

dcl  1 auto_new_proc_response
		        aligned automatic like login_server_new_proc_response;
dcl  1 auto_process_response
		        aligned automatic like login_server_process_response.fixed_part;
dcl  1 auto_termination_response
		        aligned automatic like login_server_termination_response;
dcl  1 new_proc_auth        structure aligned automatic,
       2 pad	        char (2) unaligned,
       2 authorization      bit (54) unaligned;
dcl  1 signal_term_code     structure aligned automatic,
       2 pad	        char (4) unaligned,
       2 code	        fixed bin (35) unaligned;


/* Based */

dcl  stopstop_msg	        fixed bin (71) based (addr (stopstop));
dcl  termstop_msg	        fixed bin (71) based (addr (termstop));

/* Entries */

dcl  act_ctl_$activity_unbump
		        entry (ptr, fixed bin (35));
dcl  act_ctl_$close_account entry (ptr);
dcl  act_ctl_$dp	        entry (ptr);
dcl  aim_check_$equal       entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$in_range    entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl  as_access_audit_$logout
		        entry (ptr, char (*));
dcl  as_access_audit_$process
		        entry (ptr, fixed bin, char (*));
dcl  as_any_other_handler_$no_cleanup
		        entry (char (*), label);
dcl  as_meter_$enter        entry (fixed bin);
dcl  as_meter_$exit	        entry (fixed bin);
dcl  asu_$reschedule_bump_timer
		        entry (ptr, fixed bin);
dcl  asu_$send_term_signal  entry (ptr, fixed bin) returns (bit (1) aligned);
dcl  asu_$suspend_process   entry (ptr);
dcl  convert_status_code_   entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  dpg_		        entry (ptr, char (*));
dcl  dpg_$finish	        entry (ptr);
dcl  get_process_id_        entry () returns (bit (36));
dcl  hcs_$wakeup	        entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  mc_commands_$remove_tty
		        entry (char (*), bit (1) aligned, fixed bin (35));
dcl  send_mail_$access_class
		        entry (char (*), char (*), ptr, bit (72) aligned, fixed bin (35));
dcl  timer_manager_$reset_alarm_wakeup
		        entry (fixed bin (71));
dcl  uc_create_process_     entry (ptr, fixed bin (35));
dcl  uc_logout_	        entry (ptr, char (*));
dcl  uc_send_ls_response_   entry (ptr, fixed bin (18), bit (36) aligned,
		        bit (72) aligned, fixed bin (71), ptr,
		        char (32) aligned, fixed bin (35), fixed bin (35));
dcl  user_table_mgr_$free
		        entry (ptr);

/* External */

dcl  (
     as_error_table_$activity_unbump,
     as_error_table_$automatic_logout,
     as_error_table_$bump_cancelled,
     as_error_table_$disc_hd_msg,
     as_error_table_$illegal_new_proc,
     as_error_table_$illegal_signal,
     as_error_table_$init_err,
     as_error_table_$no_disc_hd,
     as_error_table_$no_init_proc,
     as_error_table_$no_io_attach,
     as_error_table_$no_logout_hold,
     as_error_table_$no_perm_disc,
     as_error_table_$no_signal,
     as_error_table_$shutdown,
     as_error_table_$term_by_operator
     )
		        fixed bin (35) external static;
dcl  (
     error_table_$fatal_error,
     error_table_$messages_deferred,
     error_table_$messages_off,
     error_table_$null_info_ptr
     )
		        fixed bin (35) ext static;

/* Constant */

dcl  (
     FALSE	        initial ("0"b),
     TRUE		        initial ("1"b)
     )		        bit (1) aligned internal static options (constant);

dcl  MAX_USER_SIGNALS       fixed bin int static options (constant) init (19);


dcl  ME		        char (21) initial ("uc_proc_term_handler_") internal static options (constant);

dcl  (
     UNKNOWN_SOURCE	        init (0),
     RING_0	        init (1),
     USER		        init (2),
     USER_CONTROL	        init (3)
     )		        fixed bin int static options (constant);

dcl  USEC_PER_MINUTE        fixed bin (35) int static options (constant) init (60000000);
dcl  USEC_PER_SECOND        fixed bin (35) int static options (constant) init (1000000);

dcl  WAKEUP_SOURCE	        (0:3) char (16) varying int static options (constant) init (
		        "unknown source",
		        "ring 0",
		        "UTE user",
		        "user control");

dcl  (
     stopstop	        initial ("stopstop"),
     termstop	        initial ("termstop")
     )		        char (8) internal static options (constant);

/* Conditions */

dcl  any_other	        condition;
dcl  cleanup	        condition;

/* Builtin */

dcl  (addr, baseno, clock, currentsize, divide, hbound, lbound, length,
     max, null, rtrim, substr, unspec)
		        builtin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


/* Program */

	code = 0;
	event_call_info_ptr = P_event_call_info_ptr;
	ansp = as_data_$ansp;
	ip = as_data_$rs_ptrs (0);
	whoptr = as_data_$whoptr;

	anstbl.current_time = clock ();		/* Read Clock */

	metering_enabled = FALSE;
	on cleanup
	     call Clean_Up ();

	on any_other
	     call as_any_other_handler_$no_cleanup (ME, RETURN);

	if event_call_info_ptr = null ()
	then
	     call Abort (error_table_$null_info_ptr,
		"Null event_call_info pointer.");

/**** TBS: This is not strictly correct, since we're not dialup */
	metering_enabled = TRUE;
	call as_meter_$enter (DIALUP_METER);

	unspec (signal_string) = unspec (event_call_info.message);
	destroy_index = PT_FPE;			/* fatal process error is default */

	utep = event_call_info.data_ptr;

/* Ensure ute points to one of our user tables. */
	call Validate_UTEp ();

	wakeup_from = UNKNOWN_SOURCE;

	if event_call_info.ring = 0
	then
	     wakeup_from = RING_0;
	else if event_call_info.sender = get_process_id_ ()
	then
	     wakeup_from = USER_CONTROL;
	else if ute.active = NOW_HAS_PROCESS &
	     ute.proc_id = event_call_info.sender
	then
	     wakeup_from = USER;
	else
	     call Abort (-1,
		"UTE (^d, ^p in ^a) received wakeup (^a, ^24.3b) from invalid process (^12.3b).",
		ute.ute_index, utep, TABLE_NAMES (ute.process_type),
		signal_string, unspec (signal_string), event_call_info.sender);

	if ute.active = NOW_FREE
	then
	     call Abort (-1,
		"Free UTE (^d, ^p in ^a) received wakeup (^a, ^24.3b) from ^a.",
		ute.ute_index, utep, TABLE_NAMES (ute.process_type),
		signal_string, unspec (signal_string),
		WAKEUP_SOURCE (wakeup_from));

	call Setup_LS_Termination_Response ();

/**** In the event that the operator tried to bump a user who was logged
      in with no process, handle this case.  Assume that any wakeup
      sent to the UTE is a "bump" request, since no others make a whole
      lot of sense, anyway. */

	if ute.destroy_flag < WAIT_LOGOUT_SIG
	then
	     if ute.active = NOW_LOGGED_IN then do;
		call Kill_Login_and_Notify_LS ();
	     end;
	     else call Abort (-1,
		     "UTE (^d, ^p in ^a) wakeup (^a, ^24.3b) from ^a with unexpected destroy_flag (^a, ^d).",
		     ute.ute_index, utep, TABLE_NAMES (ute.process_type),
		     signal_string, unspec(signal_string), WAKEUP_SOURCE (wakeup_from),
		     TRA_VEC_VALUES (ute.destroy_flag), ute.destroy_flag);

	if wakeup_from = USER
	then
	     call Process_User_Wakeup ();
	else
	     call Process_System_Wakeup ();

	if destroy_index < lbound (term_handler, 1) |
	     destroy_index > hbound (term_handler, 1)
	then
	     call Abort (-1,
		"UTE (^d, ^p in ^a) wakeup (^a, ^24.3b) from ^a with unexpected destroy_index (^d).",
		ute.ute_index, utep, TABLE_NAMES (ute.process_type),
		signal_string, unspec(signal_string), WAKEUP_SOURCE (wakeup_from),
		destroy_index);

	signal_left_half =
	     substr (signal_string, 1, length (signal_left_half));

	if signal_string ^= "stopstop" &
	     signal_string ^= "termsgnl"
	then
	     ute.logout_type = signal_left_half;

	goto term_handler (destroy_index);

/* PT_FPE */
term_handler (1):
	if signal_left_half = "init" |
	     signal_left_half = "term" then do;
	     unspec (signal_term_code) = unspec (signal_string);
	     login_server_termination_response.status_code =
		signal_term_code.code;
	end;
	else					/* We should have SOME error code */
	     login_server_termination_response.status_code =
		error_table_$fatal_error;

	login_server_termination_response.flags.fatal_error = TRUE;
	call Prepare_To_Terminate_Process ();
	goto TERMINATE;

/**** PT_NEW_PROC */
term_handler (2):
	ute.destroy_flag = WAIT_NEW_PROC;
	goto TERMINATE;

/**** PT_LOGOUT_HOLD */
term_handler (3):
	if installation_parms.trusted_path_login then do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     login_server_termination_response.status_code =
		as_error_table_$no_logout_hold;
	end;
	else					/* ^trusted_path_login */
	     ute.destroy_flag = WAIT_LOGOUT_HOLD;
	goto TERMINATE;

/**** PT_LOGOUT */
term_handler (4):
	ute.destroy_flag = WAIT_LOGOUT;
	goto TERMINATE;

/**** PT_LOGOUT_BRIEF */
term_handler (5):
	login_server_termination_response.flags.brief = TRUE;
	ute.destroy_flag = WAIT_LOGOUT;
	goto TERMINATE;

/**** PT_LOGOUT_HOLD_BRIEF */
term_handler (6):
	if installation_parms.trusted_path_login then do;
	     login_server_termination_response.status_code =
		as_error_table_$no_logout_hold;
	     ute.destroy_flag = WAIT_LOGOUT;
	end;
	else do;					/* ^trusted_path_login */
	     login_server_termination_response.flags.brief = TRUE;
	     ute.destroy_flag = WAIT_LOGOUT_HOLD;
	end;
	goto TERMINATE;

/**** PT_INITIALIZATION_ERROR, init_err */
term_handler (7):
	login_server_termination_response.flags.offer_help = TRUE;
	login_server_termination_response.flags.fpe_during_init = TRUE;
	login_server_termination_response.status_code =
	     as_error_table_$init_err;
	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	goto TERMINATE;

/**** PT_IO_ATTACHMENT_ERROR, no_ioatt */
term_handler (8):
	login_server_termination_response.flags.offer_help = TRUE;
	login_server_termination_response.status_code =
	     as_error_table_$no_io_attach;
	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	goto TERMINATE;

/**** PT_BAD_INITIAL_PROCEDURE, no_initp */
term_handler (9):
	login_server_termination_response.status_code =
	     as_error_table_$no_init_proc;
	login_server_termination_response.flags.fpe_during_init = TRUE;
	login_server_termination_response.flags.offer_help = TRUE;
	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	goto TERMINATE;

/**** PT_DISCONNECT_COMMAND */
term_handler (10):					/* User typed disconnect */
	if ^ute.at.disconnect_ok then do;
	     login_server_termination_response.status_code =
		as_error_table_$no_perm_disc;
	     login_server_termination_response.fatal_error = TRUE;
	     call Prepare_To_Terminate_Process();
	     goto TERMINATE;
	end;
	if installation_parms.trusted_path_login then do;
	     login_server_termination_response.status_code =
		as_error_table_$no_disc_hd;
	end;
	else login_server_termination_response.status_code =
		as_error_table_$disc_hd_msg;
	goto term_handler (20);

/**** PT_OBSOLETE_1 */
term_handler (11):
	goto term_handler (PT_LOGOUT);

/**** PT_INACTIVITY_RECEIVED */
term_handler (12):

	if (ute.preempted = PREEMPT_BUMPED &
	     ute.activity_can_unbump) then do;
						/* user waiting on bump timer */
	     call asu_$reschedule_bump_timer (utep, installation_parms.warning_time);
	end;
	go to RETURN;

/**** PT_NEW_PROC_AUTH */
term_handler (13):
	ute.destroy_flag = WAIT_NEW_PROC;
	if ute.disconnected then do;
	     login_server_termination_response.status_code =
		as_error_table_$illegal_new_proc;
	     ute.destroy_flag = WAIT_LOGOUT;
	end;
	else do;					/* not a disconnected process */
	     unspec (new_proc_auth) = unspec (signal_string);
	     if ^aim_check_$in_range ((new_proc_auth.authorization),
		ute.process_authorization_range) then do;
		login_server_termination_response.status_code =
		     as_error_table_$illegal_new_proc;
	     end;
/**** TBS: Check channel authorization */
	     else if installation_parms.trusted_path_login then do;
		if ^aim_check_$equal ((new_proc_auth.authorization),
		     ute.process_authorization)
		then
		     login_server_termination_response.status_code =
			as_error_table_$illegal_new_proc;
	     end;
	     else do;				/* everything ok */
		ute.process_authorization = new_proc_auth.authorization;
		if ute.whotabx > 0
		then
		     whotab.e (ute.whotabx).process_authorization =
			ute.process_authorization;
	     end;
	end;
	goto TERMINATE;

/**** PT_TERM_SIGNAL */
term_handler (14):

/**** ute.preempted says what to do here:
     -1  user unbumped after term signal sent
      0  user unbumped; ignore alarm___
      1  value internally used in load_ctl_
      2  user bumped; when alarm___ comes in, send term signal
      3  term signal sent; destroy process if termsgnl, alarm___, or cpulimit
         signals come in
      4  user bumped; process sick, so destroy without sending term signal
      5  trm_ signal sent, termsgnl received; (if still 3, we never got the
         termsgnl).						       */

	call timer_manager_$reset_alarm_wakeup (ute.event);
	if ute.preempted = PREEMPT_UNBUMP then do;	/* unbumped too late */
	     login_server_termination_response.status_code =
		as_error_table_$bump_cancelled;
	     ute.destroy_flag = WAIT_NEW_PROC;		/* give user a new process. Best we can do. */
	     call Prepare_To_Terminate_Process ();
	end;
	else if ute.preempted = PREEMPT_TERM_SENT then do;/* sent trm_ signal, expecting this */
	     ute.preempted = PREEMPT_TERMSGNL_RECEIVED;	/* no longer expected termsgnl */
	     goto term_handler (ute.logout_index);	/* continue doing it */
	end;
	else do;					/* unexpected termsgnl */
	     login_server_termination_response.status_code =
		as_error_table_$illegal_signal;
	     login_server_termination_response.fatal_error = TRUE;
	     ute.logout_type = "term";
	     call Prepare_To_Terminate_Process ();
	end;
	goto TERMINATE;

/**** PT_UNUSED_1 */
term_handler (15):
	goto term_handler (PT_LOGOUT);

/**** PT_UNUSED_2 */
term_handler (16):
	goto term_handler (PT_LOGOUT);

/**** PT_UNUSED_3 */
term_handler (17):
	goto term_handler (PT_LOGOUT);

/**** PT_UNUSED_4 */
term_handler (18):
	goto term_handler (PT_LOGOUT);

/**** PT_UNUSED_5 */
term_handler (19):
	goto term_handler (PT_LOGOUT);

/**** PT_HANGUP */
term_handler (20):
	if ute.active = NOW_HAS_PROCESS &
	     ute.preempted <= PREEMPT_UNBUMP_IGNORE_ALARM
	then
	     if ute.save_if_disconnected then do;
		call Disconnect_Process ();
		goto RETURN;
	     end;
	     else if signal_string = "disconn" then do;
		call Disconnect_Process ();
		call Notify_LS_After_Disconnect;
		goto RETURN;
	     end;
	if asu_$send_term_signal (utep, PT_HANGUP)
	then
	     goto RETURN;				/* come back later */
	else do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     ute.logout_type = "hngp";		/* "hang" would be misleading */
	end;
	goto TERMINATE;

/**** PT_SHUTDOWN */
term_handler (21):
	if asu_$send_term_signal (utep, PT_SHUTDOWN)
	then
	     goto RETURN;
	else do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     login_server_termination_response.status_code =
		as_error_table_$shutdown;
	end;
	goto TERMINATE;

/**** PT_BUMP */
term_handler (22):
	if asu_$send_term_signal (utep, PT_BUMP)
	then
	     goto RETURN;
	else do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     login_server_termination_response.status_code =
		as_error_table_$automatic_logout;
	end;
	goto TERMINATE;

/**** PT_ALARM */
term_handler (23):
	if ute.sus_sent & ^ute.suspended
	then					/* timeout on sus response */
	     call Process_Ignored_Sus_Signal ();
	else if ute.preempted <= PREEMPT_UNBUMP_IGNORE_ALARM
	then					/* unbumped */
	     goto RETURN;
	else do;
	     if (ute.preempted = PREEMPT_BUMPED & ute.activity_can_unbump)
	     then do;
		call Process_Bump_Timer (code);	/* bump timer went off, see if user woke up */
		if code = 0
		then go to term_handler (PT_UNBUMP);	/* unbump */
	     end;
	     if asu_$send_term_signal (utep, PT_ALARM)
	     then
		goto RETURN;
	     else if ute.preempted = PREEMPT_TERM_SENT then do;
						/* already send trm_ signal */
		call Process_Ignored_Trm_Signal ();
	     end;
	     else do;
		ute.destroy_flag = WAIT_LOGOUT;
		if anstbl.session = AT_SHUTDOWN
		then
		     login_server_termination_response.status_code =
			as_error_table_$shutdown;
		else
		     login_server_termination_response.status_code =
			as_error_table_$automatic_logout;
	     end;
	end;
	goto TERMINATE;

/**** PT_DETACH, detach */
term_handler (24):
	if ute.active < NOW_HAS_PROCESS then do;	/* never get here */
	     goto RETURN;				/* handled at top */
	end;					/* of program.   */
	else if asu_$send_term_signal (utep, PT_DETACH)
	then
	     goto RETURN;
	else do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     login_server_termination_response.status_code =
		as_error_table_$automatic_logout;
	end;
	goto TERMINATE;

/**** PT_UNBUMP */
term_handler (25):
	ute.activity_can_unbump = FALSE;
	if ute.preempted = PREEMPT_TERM_SENT
	then					/* already sent trm_ */
	     ute.preempted = PREEMPT_UNBUMP;		/* remember this */
	else ute.preempted = PREEMPT_UNBUMP_IGNORE_ALARM; /* no longer preempted */
	goto RETURN;

/**** PT_STOPSTOP */
term_handler (26):
	if ute.destroy_flag <= WAIT_LOGOUT_SIG then do;
	     call Log ("Premature stopstop for ^[*^]^a.^a ^a ^12.3b.",
		(ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
		ute.proc_id);
	     call hcs_$wakeup (anstbl.as_procid, ute.event, termstop_msg, (0));
	     call hcs_$wakeup (anstbl.as_procid, ute.event, stopstop_msg, (0));
	end;
	else do;
	     call dpg_$finish (utep);
	     call act_ctl_$dp (utep);
	     ute.active = NOW_LOGGED_IN;

/**** If the user has been bumped (by the operator or for a shutdown), don't
      let him get out of the bump by getting a new process.  Otherwise,
      indicate that the user is no longer in the state of process
      destruction. */

	     if ute.destroy_flag ^= WAIT_NEW_PROC & ute.destroy_flag ^= WAIT_NEW_PROC_REQUEST
	     then
		do;
		call Close_Account_And_Logout ();
		if ute.destroy_flag = WAIT_DESTROY_REQUEST
		then
		     call Notify_LS_With_Process_Response (WAIT_DESTROY_REQUEST, 0);
	     end;
	     else do;				/* user is getting a new process */
		saved_destroy_flag = ute.destroy_flag;	/* uc_create_process_ will clobber ute.destroy_flag */

		if ute.preempted >= PREEMPT_TERM_SENT
		then
		     ute.preempted = PREEMPT_UNBUMP_IGNORE_ALARM;

		call uc_create_process_ (utep, code);
		if code ^= 0
		then
		     call Close_Account_And_Logout ();

		if saved_destroy_flag = WAIT_NEW_PROC
		then
		     call Send_New_Process_Response (code);
		else
		     call Notify_LS_With_Process_Response (saved_destroy_flag, code);

		if code = 0
		then
		     goto RETURN;			/* i.e. do not free UTE */
	     end;
	     call user_table_mgr_$free (utep);
	end;
	goto RETURN;

/**** PT_OPERATOR_TERMINATE, terminat */
term_handler (27):
	if asu_$send_term_signal (utep, PT_OPERATOR_TERMINATE)
	then
	     goto RETURN;
	else do;
	     login_server_termination_response.status_code =
		as_error_table_$term_by_operator;
	     login_server_termination_response.flags.fatal_error = TRUE;
	     call Prepare_To_Terminate_Process ();
	end;
	goto TERMINATE;

/**** PT_TERMSTOP */
term_handler (28):

	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	login_server_termination_response.status_code =
	     as_error_table_$no_signal;
	goto TERMINATE;

/**** PT_CPU_LIMIT */
term_handler (29):

	if ute.ignore_cpulimit then do;
	     ute.ignore_cpulimit = FALSE;
	     goto RETURN;
	end;
	if ute.preempted = PREEMPT_TERM_SENT then do;
	     call timer_manager_$reset_alarm_wakeup (ute.event);
	     call Process_Ignored_Trm_Signal ();
	end;
	else if ute.sus_sent then do;
	     call timer_manager_$reset_alarm_wakeup (ute.event);
	     call Process_Ignored_Sus_Signal ();
	     goto TERMINATE;
	end;
	else
	     call Abort (-1,
		"Unexpected cpulimit wakeup for ^[*^]^a.^a ^a ^12.3b.",
		(ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
		ute.proc_id);
	goto RETURN;

/**** PT_DESTROY_REQUEST */
term_handler (30):

/**** We get here when the user has used the -destroy control argument to the
      login command, or the "destroy" login server request.  The user process
      has been sent the trm_ signal, and has either responded properly with
      the "termsgnl", or our real or cpu timer has gone off.  In any case, we
      must now destroy the process.  When the process has destroyed itself,
      we receive the "stopstop" wakeup from ring-0 and the handler for this
      wakeup, above, will notify the login server for user. */

	ute.destroy_flag = WAIT_DESTROY_REQUEST;
	call Kill_Process ();
	goto RETURN;

/**** PT_NEW_PROC_REQUEST */
term_handler (31):

/**** We get here when the user has used the -new_proc control argument to the
      login command, or the "new_proc" login server request. The user process
      has been sent the trm_ signal, and has responded (or timed out).  Now
      we must destroy the process. */

	ute.destroy_flag = WAIT_NEW_PROC_REQUEST;
	call Kill_Process ();
	goto RETURN;

TERMINATE:
	call Kill_Process_And_Notify_LS ();

RETURN:
	call Clean_Up ();
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/*                 I N T E R N A L       P R O C E D U R E S	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Report errors via sys_log_$general and stop execution.	       */
/*							       */
/* Syntax:  call Abort (code, ioa_ctl, args);			       */
/*							       */
/*							       */
/* Log, Log_Error:  Report errors via sys_log_$general.		       */
/*							       */
/* Syntax:  call Log (ioa_ctl, args);				       */
/*	  call Log_Error (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_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	code = sl_info.code;
	if code ^= 0
	then go to RETURN;
	return;

Log:
     entry options (variable);
	sl_info = sl_info_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.severity = SL_LOG_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	return;

Log_Error:
     entry options (variable);
	sl_info = sl_info_code_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.severity = SL_LOG_SILENT;
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	return;

     end Abort;

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


Clean_Up:
     procedure ();

/**** Stop metering time in this procedure. */
	if metering_enabled
	then
	     call as_meter_$exit (DIALUP_METER);
	return;
     end Clean_Up;

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


Close_Account_And_Logout:
     procedure ();

	call act_ctl_$close_account (utep);
	call uc_logout_ (utep, ute.logout_type);
	return;
     end Close_Account_And_Logout;

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


Convert_Status_Code:
     procedure (P_code) returns (char (100) aligned);

dcl  P_code	        fixed bin (35) parameter;
dcl  status_code_short      char (8) aligned automatic;
dcl  status_code_string     char (100) aligned automatic;

	call convert_status_code_ (P_code, status_code_short,
	     status_code_string);
	return (status_code_string);

Convert_Status_Code_Short:
     entry (P_code) returns (char (8) aligned);

	call convert_status_code_ (P_code, status_code_short,
	     status_code_string);
	return (status_code_short);

     end Convert_Status_Code;

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


Disconnect_Process:
     procedure ();

	call asu_$suspend_process (utep);
	ute.disconnected = TRUE;
	ute.disconnection_rel_minutes = divide (clock () - ute.login_time, USEC_PER_MINUTE, 17, 0);
	if ute.whotabx > 0
	then
	     whotab.e (ute.whotabx).disconnected = TRUE;
	ute.pdtep -> user.n_disconnected =
	     max (0, ute.pdtep -> user.n_disconnected + 1);
	call as_access_audit_$process (utep, AS_AUDIT_PROCESS_DISCONNECT, "hangup");
	call as_access_audit_$logout (utep, "disconnect");
	return;
     end Disconnect_Process;

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


Get_Group_ID:
     procedure () returns (char (32) varying);

dcl  group	        char (32) varying;

	group = "";
	if ute.person ^= "" then do;
	     group = rtrim (ute.person);
	     group = group || ".";
	     group = group || rtrim (ute.project);
	     group = group || ".";
	     group = group || ute.tag;
	end;
	return (group);
     end Get_Group_ID;

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


Get_Start_Event_Channel:
     procedure () returns (fixed bin (71));

dcl  local_code	        fixed bin (35) automatic;
dcl  r_factor	        fixed bin (35) automatic;
dcl  r_offset	        fixed bin (18) automatic;
dcl  start_event_channel    fixed bin (71) automatic;

dcl  hphcs_$get_ipc_operands
		        entry (bit (36) aligned, fixed bin (18), fixed bin (35), fixed bin (35));
dcl  ipc_validate_$encode_event_channel_name
		        entry (fixed bin (18), fixed bin (35), bit (3) aligned,
		        fixed bin (15), fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (71));

/**** We must construct an event channel which will pass the IPC event
      channel validation tests. To do this, we must learn the values of
      R-Offset and R-Factor for the process. */

	call hphcs_$get_ipc_operands (ute.proc_id, r_offset, r_factor, local_code);
	if local_code = 0 then do;
	     call ipc_validate_$encode_event_channel_name (r_offset, r_factor,
		"000"b /* flags */, 1 /* index */, 4 /* ring */,
		"1"b /* regular */, 1 /* unique id */,
		start_event_channel);
	end;
	else do;
	     call Log_Error (local_code,
		"Retrieving R-Offset and R-Factor for ^[*^]^a.^a ^a ^12.3b",
		(ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
		ute.proc_id);
	     start_event_channel = 0;
	end;
	return (start_event_channel);
     end Get_Start_Event_Channel;

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


Kill_Login_and_Notify_LS:
     procedure;

dcl  1 local_ls_reply_message
		        aligned like ls_reply_message automatic;

	ls_response_ptr = addr (auto_termination_response);
	login_server_termination_response.process_id =	/* dialed terms  */
	     ute.proc_id;				/* have target   */
						/* proc's ID.    */
	login_server_termination_response.process_group_id = Get_Group_ID ();
	login_server_termination_response.status_code =
	     as_error_table_$term_by_operator;
	login_server_termination_response.flags.fatal_error = TRUE;
	login_server_termination_response.flags.logout = TRUE;
	login_server_termination_response.flags.hold = TRUE;

	unspec (local_ls_reply_message) = ""b;
	call uc_send_ls_response_ (ls_response_ptr,
	     currentsize (login_server_termination_response),
	     ute.login_server_info.process_id,
	     ute.login_server_info.his_handle,
	     ute.login_server_info.response_event_channel,
	     addr (local_ls_reply_message), (ute.tty_name), 0, code);
	if code ^= 0
	then
	     call Log_Error (code,
		"Sending termination response for ^[*^]^a.^a ^a ^12.3b to login server.",
		(ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
		ute.proc_id);

	call uc_logout_ (utep, "bump");
	if ute.login_flags.operator |
	     ute.login_flags.special_pw.dial_pw then do;
						/* MC terminal   */
	     call mc_commands_$remove_tty (ute.tty_name, "1"b, code);
	     if code ^= 0
	     then
		call Log_Error (code,
		     "Removing ^a from the MC answer table.", ute.tty_name);
	end;
	call user_table_mgr_$free (utep);
	goto RETURN;

     end Kill_Login_and_Notify_LS;

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


Kill_Process:
     procedure ();

	if ute.active = NOW_HAS_PROCESS
	then
	     call dpg_ (utep, (signal_string));
	return;
     end Kill_Process;

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


Kill_Process_And_Notify_LS:
     procedure ();

	call Kill_Process ();
	ls_response_ptr = addr (auto_termination_response);
	login_server_termination_response.process_id = ute.proc_id;
	login_server_termination_response.process_group_id = Get_Group_ID ();
	if ute.destroy_flag = WAIT_LOGOUT then do;
	     login_server_termination_response.flags.logout = TRUE;
	     login_server_termination_response.flags.hold = FALSE;
	end;
	else if ute.destroy_flag = WAIT_LOGOUT_HOLD then do;
	     login_server_termination_response.flags.logout = TRUE;
	     login_server_termination_response.flags.hold = TRUE;
	end;
	else if ute.destroy_flag = WAIT_NEW_PROC
	then
	     login_server_termination_response.flags.new_proc = TRUE;
	else
	     call Abort (-1,
		"ute.destroy_flag = ^d at after process destruction.",
		ute.destroy_flag);
	call Notify_LS ();
	return;

     end Kill_Process_And_Notify_LS;

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


Notify_LS:
     procedure;

dcl  1 local_ls_reply_message
		        aligned like ls_reply_message automatic;

	login_server_termination_response.accounting_info.cpu_usage =
	     ute.cpu_usage;
	login_server_termination_response.accounting_info.cost =
	     ute.session_cost;

	unspec (local_ls_reply_message) = ""b;
	call uc_send_ls_response_ (ls_response_ptr,
	     currentsize (login_server_termination_response),
	     ute.login_server_info.process_id,
	     ute.login_server_info.his_handle,
	     ute.login_server_info.termination_event_channel,
	     addr (local_ls_reply_message), (ute.tty_name), 0, code);
	if code ^= 0
	then
	     call Log_Error (code,
		"Could not send process termination response for ^a.^a.^a to login server.",
		ute.person, ute.project, ute.tag);

     end Notify_LS;

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


Notify_LS_After_Disconnect:				/* Called for    */
     procedure ();					/*  user-typed   */
						/*  disconnect   */
						/*  command.     */

	login_server_termination_response.flags.logout = TRUE;
	if login_server_termination_response.status_code =
	     as_error_table_$disc_hd_msg
	then
	     login_server_termination_response.flags.hold = TRUE;
	else login_server_termination_response.flags.hold = FALSE;
	call Notify_LS ();
	return;

     end Notify_LS_After_Disconnect;

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


Notify_LS_With_Process_Response:
     procedure (P_reason, P_code);

/**** This procedure is called to notify the Login Server for a user of the
      successful execution of the "destroy" or "new_proc" login server
      requests. */

dcl  P_reason	        fixed bin parameter;
dcl  P_code	        fixed bin (35) parameter;

dcl  1 local_ls_reply_message
		        aligned like ls_reply_message automatic;

	unspec (local_ls_reply_message) = ""b;
	local_ls_reply_message.code = P_code;

	ls_process_response_accounting_message_length = 0;
	ls_response_ptr = addr (auto_process_response);
	unspec (login_server_process_response) = ""b;

	login_server_process_response.header.message_type = LS_PROCESS_RESPONSE;
	login_server_process_response.header.version = LOGIN_SERVER_PROCESS_RESPONSE_VERSION_1;

	login_server_process_response.status_code = P_code;
	login_server_process_response.process_id = ute.proc_id;
/**** Since we've switched UTEs on the loging server, we need to apprise it
      of the new handle associated with this connection. */

	login_server_process_response.new_handle = ute.login_server_info.our_handle;
	login_server_process_response.authorization = ute.process_authorization;
	login_server_process_response.process_group_id = Get_Group_ID ();
	login_server_process_response.process_number = 0;

	if ute.pdtep ^= null
	then
	     login_server_process_response.n_disconnected_processes =
		ute.pdtep -> user.n_disconnected;
	else login_server_process_response.n_disconnected_processes = 0;

	if P_reason = WAIT_NEW_PROC_REQUEST
	then
	     login_server_process_response.start_event_channel = Get_Start_Event_Channel ();

	login_server_process_response.login_instance = 0;

	login_server_process_response.accounting_info.cpu_usage = ute.cpu_usage;
	login_server_process_response.accounting_info.cost = ute.session_cost;

	if P_reason = WAIT_DESTROY_REQUEST
	then do;
	     login_server_process_response.flags.destroyed = TRUE;
/**** This could be based on an installation parameter */
	     login_server_process_response.flags.logout = TRUE;
	end;
	else if P_reason = WAIT_NEW_PROC_REQUEST
	then
	     login_server_process_response.flags.new_proc = TRUE;

	login_server_process_response.initial_ring = ute.initial_ring;
	login_server_process_response.already_logged_in_info.connection_name = "";
	login_server_process_response.already_logged_in_info.terminal_type = "";
	login_server_process_response.already_logged_in_info.terminal_id = "";
	login_server_process_response.accounting_message_length = 0;

	call uc_send_ls_response_ (ls_response_ptr,
	     currentsize (login_server_process_response),
	     ute.login_server_info.process_id,
	     ute.login_server_info.his_handle,
	     ute.login_server_info.response_event_channel,
	     addr (local_ls_reply_message), (ute.tty_name), 0, code);
	if code ^= 0
	then
	     call Log_Error (code, "Sending login server response for process destruction of ^a.^a.^a.", ute.person,
		ute.project, ute.tag);
	return;
     end Notify_LS_With_Process_Response;

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


Prepare_To_Terminate_Process:
     procedure ();

          call as_access_audit_$process (utep, AS_AUDIT_PROCESS_TERMINATE,
	     Convert_Status_Code_Short(
	     login_server_termination_response.status_code));
	if ute.disconnected
	then
	     ute.destroy_flag = WAIT_LOGOUT;
	else if substr (signal_string, 1, 4) = "init" then do;
						/* during init */
	     ute.destroy_flag = WAIT_LOGOUT_HOLD;
	     login_server_termination_response.flags.fpe_during_init = TRUE;
	     login_server_termination_response.flags.offer_help = TRUE;
	end;
	else do;					/* not during init */
	     if ute.recent_fatal_error_time +
		installation_parms.fatal_error_loop_seconds * USEC_PER_SECOND <
		anstbl.current_time then do;
		if ute.uflags.fpe_causes_logout then do;
		     login_server_termination_response.flags.fpe_caused_logout = TRUE;
		     ute.destroy_flag = WAIT_LOGOUT_HOLD;
		end;
		else do;				/* ^fpe_causes_logout */
		     ute.recent_fatal_error_time = anstbl.current_time;
		     ute.recent_fatal_error_count = 1;
		     ute.destroy_flag = WAIT_NEW_PROC;
		end;
	     end;
	     else do;				/* recent fatal process error */
		ute.recent_fatal_error_count =
		     ute.recent_fatal_error_count + 1;
		if ute.recent_fatal_error_count <
		     installation_parms.fatal_error_loop_count
		then
		     ute.destroy_flag = WAIT_NEW_PROC;
		else				/* exceeded fatal_error_loop_count */
		     do;
		     ute.destroy_flag = WAIT_LOGOUT_HOLD;
		     login_server_termination_response.flags.fpe_loop = TRUE;
		     login_server_termination_response.flags.offer_help = TRUE;
		end;
	     end;
	end;
	return;
     end Prepare_To_Terminate_Process;

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


Process_Bump_Timer:
     procedure (P_code);

dcl  P_code	        fixed bin (35);
dcl  code		        fixed bin (35);
dcl  user_id	        char (32);

	call act_ctl_$activity_unbump (utep, P_code);
	if P_code = 0 then do;			/* acceptably active */
	     call Log ("Cancelling inactivity bump of ^a.^a", ute.person, ute.project);
						/* notify user of unbump */
	     user_id = rtrim (ute.person) || "." ||	/* build Person.Project */
		rtrim (ute.project);
	     unspec (send_mail_info) = "0"b;
	     send_mail_info.version = send_mail_info_version_2;
	     send_mail_info.wakeup = "1"b;
	     send_mail_info.always_add = "1"b;
	     send_mail_info.sent_from = "answering service";

	     call send_mail_$access_class (user_id, Convert_Status_Code (as_error_table_$activity_unbump),
		addr (send_mail_info), ute.process_authorization, code);
	     if code ^= 0 & code ^= error_table_$messages_deferred & code ^= error_table_$messages_off
	     then call Log_Error (code, "When attempting to notify user ^a of dialup event", user_id);
	end;
     end Process_Bump_Timer;

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


Process_Ignored_Sus_Signal:
     procedure ();

	call Log ("sus_ signal ignored by ^[*^]^a.^a ^a ^12.3b.",
	     (ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
	     ute.proc_id);

	if asu_$send_term_signal (utep, PT_HANGUP)
	then
	     goto RETURN;
	else
	     ute.destroy_flag = WAIT_LOGOUT;
	return;
     end Process_Ignored_Sus_Signal;

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


Process_Ignored_Trm_Signal:
     procedure ();

	ute.preempted = PREEMPT_TERMSGNL_RECEIVED;	/* no longer waiting termsgnl */

	call Log ("process ignored trm_ signal ^a.^a.^a on channel ^a.",
	     ute.person, ute.project, ute.tag, ute.tty_name);

	if ute.logout_index = PT_ALARM then do;		/* bump */
	     ute.destroy_flag = WAIT_LOGOUT;
	     if anstbl.session = AT_SHUTDOWN
	     then
		login_server_termination_response.status_code =
		     as_error_table_$shutdown;
	     else
		login_server_termination_response.status_code =
		     as_error_table_$automatic_logout;
	     call Kill_Process_And_Notify_LS ();
	end;
	else goto term_handler (ute.logout_index);	/* not bump */

     end Process_Ignored_Trm_Signal;

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


Process_Sus_Response:
     procedure ();

	ute.sus_channel = event_call_info.message;
	if ^ute.ignore_cpulimit then do;		/* not released before responded */
	     ute.suspended = TRUE;
	     if ute.whotabx > 0
	     then
		whotab.e (ute.whotabx).suspended = TRUE;
/**** Turn off realtime timer we set for responded to sus_ signal. */
	     call timer_manager_$reset_alarm_wakeup (ute.event);
	end;
	else do;					/* released before responded */
	     ute.sus_sent = FALSE;
	     if ute.whotabx > 0
	     then
		whotab.e (ute.whotabx).suspended = FALSE;
/**** Tell process it may run again. */
	     call hcs_$wakeup (ute.proc_id, ute.sus_channel, 0, (0));
	end;
	return;

     end Process_Sus_Response;

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


Process_System_Wakeup:
     procedure ();

	do destroy_index = 1 to as_data_$system_signal_types.n_system_signals
	     while (signal_string ^=
	     as_data_$system_signal_types.system_signals (destroy_index));
	end;

	if destroy_index <=
	     as_data_$system_signal_types.n_system_signals
	then
	     destroy_index = destroy_index + MAX_USER_SIGNALS;
	else
	     call Abort (-1, "Invalid system signal ^a.", signal_string);
	return;
     end Process_System_Wakeup;

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


Process_User_Wakeup:
     procedure ();

	do destroy_index = 1 to as_data_$signal_types.n_signals
	     while (signal_string ^=
	     as_data_$signal_types.signals (destroy_index));
	end;

	if destroy_index <= as_data_$signal_types.n_signals
	then ;
	else if substr (signal_string, 1, 4) = "term" |
	     substr (signal_string, 1, 4) = "init"
	then
	     destroy_index = PT_FPE;
	else if substr (signal_string, 1, 2) = "np"
	then
	     destroy_index = PT_NEW_PROC_AUTH;
	else if ute.sus_sent & ^ute.suspended then do;
	     call Process_Sus_Response ();
	     goto RETURN;
	end;
	else do;
	     login_server_termination_response.status_code =
		as_error_table_$illegal_signal;
	     login_server_termination_response.flags.fatal_error = TRUE;
	     call Prepare_To_Terminate_Process ();
	     goto TERMINATE;
	end;
	return;
     end Process_User_Wakeup;

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


Setup_LS_Termination_Response:
     procedure ();

	ls_response_ptr = addr (auto_termination_response);
	unspec (login_server_termination_response) = ""b;
	login_server_termination_response.header.message_type =
	     LS_TERMINATION_RESPONSE;
	login_server_termination_response.header.version =
	     LOGIN_SERVER_TERMINATION_RESPONSE_VERSION_1;
	login_server_termination_response.process_id = ute.proc_id;
	login_server_termination_response.process_group_id = Get_Group_ID ();
	return;
     end Setup_LS_Termination_Response;

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


Send_New_Process_Response:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;
dcl  1 local_ls_reply_message
		        aligned like ls_reply_message automatic;

	if P_code ^= 0
	then
	     do;
	     call Log_Error (P_code, "Could not create new process for ^a.^a.^a.", ute.person, ute.project, ute.tag);
	     return;
	end;

	ls_response_ptr = addr (auto_new_proc_response);
	unspec (login_server_new_proc_response) = ""b;
	login_server_new_proc_response.header.message_type =
	     LS_NEW_PROC_RESPONSE;
	login_server_new_proc_response.header.version =
	     LOGIN_SERVER_NEW_PROC_RESPONSE_VERSION_1;
	login_server_new_proc_response.new_authorization =
	     ute.process_authorization;
	login_server_new_proc_response.new_start_event_channel =
	     Get_Start_Event_Channel ();
	login_server_new_proc_response.new_process_id =
	     ute.proc_id;

	unspec (local_ls_reply_message) = ""b;
	call uc_send_ls_response_ (ls_response_ptr,
	     currentsize (login_server_new_proc_response),
	     ute.login_server_info.process_id,
	     ute.login_server_info.his_handle,
	     ute.login_server_info.termination_event_channel,
	     addr (local_ls_reply_message), (ute.tty_name), 0, code);
	if code ^= 0
	then
	     call Log_Error (code,
		"Sending new process login server response for ^[*^]^a.^a ^a ^12.3b.",
		(ute.anonymous = 1), ute.person, ute.project, ute.tty_name,
		ute.proc_id);
	return;
     end Send_New_Process_Response;

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


Validate_UTEp:
     procedure ();

/**** Ensure the utep supplied as the event call data pointer points into
      either the answer_table, the absentee_user_table, or the
      daemon_user_table.  Otherwise, reject the wakeup. */

	if utep = null ()
	then
	     call Abort (error_table_$null_info_ptr,
		"Null UTE pointer with wakeup (^a, ^24.3b) from process ^12.3b.",
		signal_string, unspec (signal_string),
		event_call_info.sender);

	if baseno (utep) ^= baseno (as_data_$ansp) &
	     baseno (utep) ^= baseno (as_data_$autp) &
	     baseno (utep) ^= baseno (as_data_$dutp)
	then
	     call Abort (-1,
		"Invalid UTE pointer (^p) with wakeup (^a, ^24.3b) from process ^12.3b.",
		utep, signal_string, unspec (signal_string),
		event_call_info.sender);
	return;
     end Validate_UTEp;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
/* format: off */
 %include access_audit_bin_header; /* not used, but needed by PL/I */
 %include answer_table;
 %include as_audit_structures;
 %include as_data_;
 %include as_meter_numbers;
 %include dialup_values;
 %include event_call_info;
 %include installation_parms;
 %include login_server_messages;
 %include pdt;

dcl  pdtp		        pointer automatic init(null);	/* required by pdt.incl.pl1 */
 %include send_mail_info;
 %include sys_log_constants;
 %include user_attributes;
 %include user_table_entry;
 %include user_table_header;
 %include whotab;

end uc_proc_term_handler_;




		    uc_send_ls_response_.pl1        08/04/87  1511.0rew 08/04/87  1511.0       89973



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-05-16,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations.
      B) Allow caller to control whether a response message is sent.
      C) If reply wakeup cannot be sent, force_disconnect the MNA connection.
  3) change(87-05-21,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add sys_log_ error message to diagnose failure to add user_message
         or failure to send wakeup to login server.
  4) change(87-05-22,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Copy event channel from parameter for use in hcs_$wakeup call.
      B) Log error message for failure to add user message.
      C) Centralize call to Force_Disconnect in an Abort procedure.
  5) change(87-07-28,GDixon), approve(87-07-28,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Move call to sys_log_$general to correct place within the Abort proc.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_send_ls_response_:
     procedure (P_data_ptr, P_data_lth, P_ls_process_id, P_ls_handle,
	P_ls_event_channel, P_ls_reply_message_ptr, P_connection_name,
	P_reply_code, P_code);

/* Parameters */

dcl  P_data_ptr	        ptr parameter;
dcl  P_data_lth	        fixed bin (18) parameter;
dcl  P_ls_process_id        bit (36) aligned parameter;
dcl  P_ls_handle	        bit (72) aligned parameter;
dcl  P_ls_event_channel     fixed bin (71) parameter;
dcl  P_ls_reply_message_ptr ptr parameter;
dcl  P_connection_name      char (32) aligned parameter;
dcl  P_reply_code	        fixed bin (35) parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  1 asum_ai	        aligned like as_user_message_add_info automatic;
dcl  connection_name        char (32) aligned automatic;
dcl  code		        fixed bin (35) automatic;
dcl  data_ptr	        ptr automatic;
dcl  data_lth	        fixed bin (18) automatic;
dcl  ls_process_id	        bit (36) aligned automatic;
dcl  ls_handle	        bit (72) aligned automatic;
dcl  ls_event_channel       fixed bin (71) automatic;
dcl  reply_code	        fixed bin (35) automatic;

/* Based */

dcl  based_event_message    fixed bin (71) based;

/* Entries */

dcl  as_user_message_$priv_add_message entry (ptr, fixed bin (35));
dcl  hcs_$make_entry        entry (ptr, char (*), char (*), entry, fixed bin (35));
dcl  hcs_$wakeup	        entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hpriv_connection_list_$get_name
		        entry (char (*), ptr, fixed bin (35));

/* Constant */

dcl  FALSE	        bit (1) aligned initial ("0"b) internal static options (constant);
dcl  LOGIN_SERVER_RING      fixed bin int static options (constant) init (4);
dcl  ME		        char (20) int static options (constant) init ("uc_send_ls_response_");
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);


/* Builtins */

dcl  (addr, after, before, null, unspec)
		        builtin;

/* Program */

	data_ptr = P_data_ptr;
	data_lth = P_data_lth;
	ls_process_id = P_ls_process_id;
	ls_handle = P_ls_handle;
	ls_event_channel = P_ls_event_channel;
	ls_reply_message_ptr = P_ls_reply_message_ptr;
	connection_name = P_connection_name;
	reply_code = P_reply_code;
	code = 0;

	if ls_reply_message.do_not_reply then goto RETURN;
	if ls_event_channel = 0 then goto RETURN;

	if unspec (ls_reply_message) = ""b then do;
	     ls_reply_message.code = reply_code;
	     ls_reply_message.flags = FALSE;
	end;

	if data_lth > 0 then do;
	     unspec (asum_ai) = ""b;
	     asum_ai.version = AS_USER_MESSAGE_ADD_INFO_VERSION_1;
	     asum_ai.message_ptr = data_ptr;
	     asum_ai.message_length = data_lth;
	     asum_ai.message_access_class = ""b;
	     asum_ai.destination_info.group_id = "";
	     asum_ai.destination_info.process_id = ls_process_id;
	     asum_ai.destination_info.handle = ls_handle;
	     asum_ai.destination_info.ring = LOGIN_SERVER_RING;
	     asum_ai.reader_deletes = "1"b;
	     call as_user_message_$priv_add_message (addr (asum_ai), code);
	     if code ^= 0 then
		call Abort (SL_LOG_BEEP, code,
		"Sending response via as_user_message_$priv_add_message.");
	     ls_reply_message.response_sent = TRUE;
	end;

	call hcs_$wakeup (ls_process_id, ls_event_channel,
	     ls_reply_message_ptr -> based_event_message, code);
	if code ^= 0 then 
	     call Abort (SL_LOG, code,
	     "Sending wakeup for ^a to Login_Server ^12.3b event channel ^24.3b.",
	     connection_name, ls_process_id, unspec(ls_event_channel));

RETURN:
	P_code = code;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: log an error via sys_log_$general, force_disconnect the terminal   */
/* and abort execution.					       */
/*							       */
/* 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 do;
	     call Force_Disconnect (connection_name);
	     go to RETURN;
	end;

     end Abort;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* if couldn't notify owner, then try to disconnect the connection ourselves */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


Force_Disconnect:
     procedure (P_connection_name);

dcl  P_connection_name      char (32) aligned;

dcl  code		        fixed bin (35);
dcl  connection_name        char (32);
dcl  entry_point_name       char (60);
dcl  ref_name	        char (32);
dcl  entry_to_call	        entry (char (*), fixed bin (35)) variable;

	connection_name = P_connection_name;

	if connection_name ^= "" then do;
	     aci.version = ACT_INFO_VERSION_1;
	     call hpriv_connection_list_$get_name (connection_name,
		addr (aci), code);
	     if code = 0 then do;
		if aci.force_disconnect_entry ^= "" then do;
		     ref_name = before (
			aci.force_disconnect_entry, "$");
		     entry_point_name = after (
			aci.force_disconnect_entry, "$");
		     if entry_point_name = "" then
			entry_point_name = ref_name;
		     call hcs_$make_entry (null (), ref_name,
			entry_point_name, entry_to_call, code);
		     if code = 0
		     then call entry_to_call (connection_name, code);
		     if code ^= 0
		     then call Log_Error_With_Code (code,
			     "Calling Force_Disconnect procedure ^a$^a.",
			     ref_name, entry_point_name);
		end;
	     end;
	end;
	return;

     end Force_Disconnect;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error_With_Code: log an error via sys_log_$general and continue       */
/* execution.						       */
/*							       */
/* Syntax:  call Log_Error_With_Code (code, ioa_ctl, args);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Log_Error_With_Code:
     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.severity = SL_LOG_SILENT;
	sl_info.caller = ME;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));

     end Log_Error_With_Code;

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


/* format: off */
 %include active_connection_info;

dcl  1 aci	        aligned like active_connection_info;
 %include as_user_message_add;
 %include login_server_messages;
 %include sys_log_constants;
     end uc_send_ls_response_;





		    uc_set_pit_tty_info_.pl1        07/13/88  1113.4r w 07/13/88  0936.4       56619



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


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-15,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
  3) change(87-05-14,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Replace error logging with calls to sys_log_$general.
      b) Set pit.line_type from ute.line_type.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_set_pit_tty_info_:
     procedure (P_utep, P_code);

/* Parameters */

dcl  P_code	        fixed bin (35) parameter;
dcl  P_utep	        ptr parameter;

/* Automatic */

dcl  code		        fixed bin (35) automatic;

/* Entries */

dcl  hcs_$truncate_seg      entry (ptr, fixed bin (19), fixed bin (35));
dcl  hphcs_$set_pit_tty_info entry (bit (36) aligned, ptr, fixed bin (35));

/* External */

dcl  error_table_$out_of_sequence fixed bin (35) ext static;

/* Constant */

dcl  ME		        char (20) initial ("uc_set_pit_tty_info_") internal static options (constant);

/* Builtins */

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

%page;
/* Program */

	utep = P_utep;
	code = 0;

	if ^ute.uflags.proc_create_ok then
	     call Abort (error_table_$out_of_sequence);

	call Setup_PIT ();
	call hphcs_$set_pit_tty_info (ute.proc_id, pit_ptr, code);
	if code ^= 0 then
	     call Log_Error_with_Code (code,
		"Could not set tty info in PIT for ^a.^a.^a on channel ^a.",
		ute.person, ute.project, ute.tag, ute.tty_name);
RETURN:
	P_code = code;
	return;
%page;
Setup_PIT:
     procedure ();

	pit_ptr = as_data_$pit_ptr;
	call hcs_$truncate_seg (pit_ptr, 0, code);
	if code ^= 0 then
	     call Abort (code, "Could not truncate the pit template.");

	pit.version = PIT_version_3;
	pit.tty = ute.tty_name;
	if length (rtrim (pit.tty)) <= length (pit.old_tty) then
	     pit.old_tty = substr (pit.tty, 1, length (pit.old_tty));
	pit.terminal_access_class = ""b;		/* not used */
	pit.line_type = ute.line_type;
	pit.term_type_name = ute.terminal_type;
/**** TBS: If the value of pit.service is type is used, it will have to
      be conjured up from somewhere.  The cdte, of course, has this value
      for MCS channels.  It was probably only used for the old NCP/FTP. */
	pit.service_type = 0;
/**** TBS: The charge_type is available in the cdte for MCS channels.  If
      this module ever supports MCS, it should be extracted from here. */
	pit.charge_type = 0;
	pit.tty_answerback = ute.tty_id_code;
/**** TBS: The tty_type is an obsolete field which is present in the cdte.
      If this module ever supports MCS, it should be extracted from here. */
	pit.tty_type = 0;
	pit.outer_module = ute.outer_module;
	return;

     end Setup_PIT;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report an error via sys_log_$general and stop execution if a       */
/* nonzero code was given.					       */
/*							       */
/* 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.severity = SL_LOG_SILENT;
	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 RETURN;

     end Abort;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Log_Error_with_Code: log an error via sys_log_$general and continue       */
/* execution.						       */
/*							       */
/* Syntax:  call Log_Error_with_Code (code, ioa_ctl, args);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Log_Error_with_Code:
     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.severity = SL_LOG_SILENT;
	sl_info.caller = ME;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	call sys_log_$general (addr (sl_info));

     end Log_Error_with_Code;

/* format: off */
%page; %include as_data_;
%page; %include access_audit_bin_header; /* needed by PL/I */
%page; %include as_audit_structures;
%page; %include dialup_values;
%page; %include pit;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;

end uc_set_pit_tty_info_;





		    uc_setup_process_connect_.pl1   07/13/88  1113.4r w 07/13/88  0938.3      151479



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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This module is part of the Multics Network Architecture (MNA) version of  */
/* user control.  MNA user control serves users coming into Multics via      */
/* separate networks (eg, the Distributed Systems Architecture (DSA)	       */
/* network.  MNA user control is not used for logins through the Multics     */
/* Communications System (MCS).  A separate MCS user control system serves   */
/* MCS users.						       */
/*							       */
/* To Be Supplied:						       */
/*  1) Brief module description.  See MDD010 or MTBs 751 and 752 for details */
/*     about this module, and its relationship to modules in the MCS user    */
/*     control system.					       */
/*  2) Operator error message documentation.  This program calls	       */
/*     sys_log_$general but does not contain the required descriptions of    */
/*     these messages.  This omission was waived for initial installation    */
/*     of the subsystem by the auditor, security coordinator, and by MDC     */
/*     management.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-16,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-28,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
  3) change(87-05-15,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add cleanup handler; convert to sys_log_$general.
      B) Add check for process ring below minimum login server ring.
      C) Set ute.line_type.
      D) Allow reconnecting user to respecify ute.outer_module.
  4) change(87-05-20,GDixon), approve(87-07-13,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
     When an MNA user logs in, a UTE is created.  When this user connects to an
     existing process, that proc's UTE is retained and the login UTE is freed;
     but the whotab is never updated to reflect freeing of the login UTE.
      A) Call uc_logout_$reconnect to do all aspects of logging out the login
         UTE except for auditing the LOGOUT.  Instead, we audit a CONNECT
         operation.
  5) change(87-07-28,GDixon), approve(87-07-28,MCR7737),
     audit(87-07-30,Brunelle), install(87-08-04,MR12.1-1055):
      A) Remove redundant statement in Set_Outer_Module proc.
                                                   END HISTORY COMMENTS */

/* format: style4,indattr */

uc_setup_process_connect_:
     procedure (P_ls_request_server_info_ptr,
	P_ls_request_ptr, P_ls_request_lth,
	P_ls_response_ptr, P_ls_response_lth,
	P_ls_ipc_reply_ptr, P_utep, P_code);

/* Parameters */

dcl  P_ls_request_server_info_ptr ptr parameter;
dcl  P_ls_request_ptr       ptr parameter;
dcl  P_ls_request_lth       fixed bin (18) parameter;
dcl  P_ls_response_ptr      ptr parameter;
dcl  P_ls_response_lth      fixed bin (18) parameter;
dcl  P_ls_ipc_reply_ptr     ptr parameter;
dcl  P_utep	        ptr parameter;
dcl  P_code	        fixed bin (35) parameter;

/* Automatic */

dcl  added_info	        char(128);
dcl  code		        fixed bin (35) automatic;
dcl  process_number	        fixed bin automatic;
dcl  saved_utep	        ptr automatic;
dcl  temp_utep	        ptr automatic;
dcl  whoptr	        ptr automatic;

/* Entries */

dcl  aim_check_$equal       entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  as_access_audit_$process entry (ptr, fixed bin, char (*));
dcl  as_access_audit_$process_connect_denied entry (ptr, ptr, char (*));
dcl  as_any_other_handler_$no_cleanup entry (char (*), label);
dcl  asu_$release_suspended_process entry (ptr);
dcl  asu_$setup_login_server_handle entry (ptr);
dcl  display_access_class_  entry (bit(72) aligned) returns(char(32) aligned);
dcl  get_system_free_area_  entry() returns(ptr);
dcl  ioa_$rsnnl	        entry () options (variable);
dcl  ipc_$decl_event_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  uc_list_disconnected_procs_ entry (ptr, ptr, ptr);
dcl  uc_logout_$reconnect   entry (ptr, char(*));
dcl  uc_proc_term_handler_  entry (ptr);
dcl  uc_set_pit_tty_info_   entry (ptr, fixed bin (35));
dcl  user_table_mgr_$free entry (ptr);
dcl  user_table_mgr_$utep_from_handle entry (bit (72) aligned) returns (ptr);

/* External */

dcl  as_error_table_$dialup_error fixed bin (35) ext static;
dcl  as_error_table_$illegal_om_arg fixed bin(35) ext static;
dcl  as_error_table_$no_connect_aclass fixed bin (35) ext static;
dcl  as_error_table_$no_disconnected_procs fixed bin (35) ext static;
dcl  as_error_table_$no_such_process_msg fixed bin (35) ext static;
dcl  as_error_table_$ring_too_low fixed bin(35) ext static;
dcl  error_table_$bad_arg   fixed bin (35) ext static;
dcl  error_table_$id_not_found fixed bin (35) ext static;

/* Based */

dcl  system_area	        area based (system_area_ptr);

/* Internal */

dcl  system_area_ptr        ptr int static init(null);

/* Constant */

dcl  FALSE	        bit (1) aligned initial ("0"b) internal static options (constant);
dcl  ME		        char (25) initial ("uc_setup_process_connect_") internal static options (constant);
dcl  TRUE		        bit (1) aligned initial ("1"b) internal static options (constant);

/* Conditions */

dcl (any_other, cleanup)    condition;

/* Builtins */

dcl (addr, currentsize, max, null, unspec)
		        builtin;

/* Program */

	ls_request_server_info_ptr = P_ls_request_server_info_ptr;
	ls_request_ptr = P_ls_request_ptr;
	ls_reply_message_ptr = P_ls_ipc_reply_ptr;
	P_utep = null;
	code = 0;

	if system_area_ptr = null then
	     system_area_ptr = get_system_free_area_();
	uc_disconnected_process_list_ptr = null ();
	on cleanup begin;
	     if uc_disconnected_process_list_ptr ^= null then
		free uc_disconnected_process_list in (system_area);
	end;

	on any_other
	     call as_any_other_handler_$no_cleanup (ME, FAULT_LABEL);

	utep = user_table_mgr_$utep_from_handle (
	     login_server_process_request.handle);
	if utep = null () then
	     call Abort_With_Error (SL_LOG_SILENT,
	     error_table_$id_not_found, 
	     "Could not locate user table entry for handle ^24.3b.",
	     login_server_process_request.handle);

	if ute.person ^= login_server_process_request.person_id |
	     ute.project ^= login_server_process_request.project_id then
	     call Abort_With_Error (SL_LOG_SILENT, error_table_$bad_arg,
	     "Person.Project in connect request (^a.^a) do not match UTE (^a.^a).",
	     login_server_process_request.person_id,
	     login_server_process_request.project_id, ute.person,
	     ute.project);

	call uc_list_disconnected_procs_ (utep, addr(system_area),
	     uc_disconnected_process_list_ptr);

	if uc_disconnected_process_list_ptr = null () then
	     call Abort (as_error_table_$no_disconnected_procs);

	if uc_disconnected_process_list.n_disconnected_processes = 0 then
	     call Abort (as_error_table_$no_disconnected_procs);

	process_number = login_server_process_request.process_number;
	if process_number = 0 &
	     uc_disconnected_process_list.n_disconnected_processes = 1 then
	     process_number = 1;

	if process_number < 1 |
	   process_number >
	     uc_disconnected_process_list.n_disconnected_processes then
	     call Abort (as_error_table_$no_such_process_msg);

	temp_utep =
	     uc_disconnected_process_list.process (process_number).utep;

	if ^aim_check_$equal (ute.process_authorization,
	     temp_utep -> ute.process_authorization) then do;
	     call ioa_$rsnnl ("User authorization = ^a, Process authorization = ^a",
		added_info, (0),
		display_access_class_ (ute.process_authorization),
		display_access_class_ (
		temp_utep -> ute.process_authorization));
	     call as_access_audit_$process_connect_denied (utep, temp_utep,
		added_info);
	     call Abort (as_error_table_$no_connect_aclass);
	end;
     
	if login_server_process_request.other_flags.minimum_ring_given then
	     if temp_utep -> ute.initial_ring <
		login_server_process_request.minimum_ring then do;
		call ioa_$rsnnl ("Connection minimum ring = ^d, Process initial ring = ^d",
		     added_info, (0),
		     login_server_process_request.minimum_ring,
		     temp_utep -> ute.initial_ring);
		call as_access_audit_$process_connect_denied (utep,
		     temp_utep, added_info);
		call Abort (as_error_table_$ring_too_low);
	     end;

/**** Make UTE for disconnected process ute associated with this connection.
      This includes copying ute lock state into the disconnected UTE.        */
	temp_utep -> ute.lock_value =
	     temp_utep -> ute.lock_value + ute.lock_value;
	saved_utep = utep;				/* save old UTE pointer */
	utep = temp_utep;				/* switch UTEs */
	P_utep = utep;				/* tell caller where we are */

/**** Update the connection information into the new UTE.		       */
	ute.tty_name = login_server_process_request.connection_info.connection_name;
	ute.tty_id_code = login_server_process_request.connection_info.terminal_id;
	ute.terminal_type = login_server_process_request.connection_info.terminal_type;
	ute.line_type = login_server_process_request.connection_info.line_type;

/**** We should allow the user to specify a new outer module.  We must,
      however, validate the user's ability to select one. */
	call Setup_Outer_Module();

	if login_server_process_request.switch_flags.brief_given then do;
	     ute.at.brief = login_server_process_request.switch_values.brief;
	     ute.ur_at.brief = TRUE;
	end;

/**** Copy the login_server process_id, event_channel, and handle from
      the new UTE into the old UTE.  Keep the handle which encodes the old
      UTE, however. */

	ute.login_server_info.his_handle = saved_utep -> ute.login_server_info.his_handle;
	ute.login_server_info.response_event_channel = saved_utep -> ute.login_server_info.response_event_channel;
	ute.login_server_info.termination_event_channel = saved_utep -> ute.login_server_info.termination_event_channel;
	ute.login_server_info.process_id = saved_utep -> ute.login_server_info.process_id;

/**** If, however, login_server_info.our_handle equals 0, then this UTE was
      created via MCS (not MNA).  We must create a handle. */

	if ute.login_server_info.our_handle = ""b then
	     call asu_$setup_login_server_handle (utep);

/**** Here, we re-declare the event channel associated with this UTE to
      be associated with our event call handler, uc_proc_term_handler_.
      This UTE might have been associated with an MCS channel before, and
      hence used another event call handler (presumably dialup_). */

	call ipc_$decl_event_call_chn (ute.event, uc_proc_term_handler_, utep, 1 /* priority */, code);
	if code ^= 0 then				/* let user reconnect, but they'll be problems later */
	     call Error_No_Abort (SL_LOG_BEEP, code,
	     "Setting event call handler at reconnection for ^a.^a ^a ^w.",
	     ute.person, ute.project, ute.tty_name, ute.proc_id);

	call as_access_audit_$process (utep, AS_AUDIT_PROCESS_CONNECT,
	     "");
	call uc_logout_$reconnect (saved_utep, "");	/* Remove login UTE from whotab */
	call user_table_mgr_$free (saved_utep);
	call uc_set_pit_tty_info_ (utep, code);
	if code ^= 0 then
	     call Error_No_Abort (SL_LOG_SILENT, code,
	     "Setting pit tty info at reconnection for ^a.^a ^a ^w.",
	     ute.person, ute.project, ute.tty_name, ute.proc_id);

	call asu_$release_suspended_process (utep);

	ute.pdtep -> user.n_disconnected =
	     max (0, ute.pdtep -> user.n_disconnected - 1);
	ute.disconnected = FALSE;
	if ute.whotabx > 0 then do;
	     whoptr = as_data_$whoptr;
	     whotab.e (ute.whotabx).disconnected = FALSE;
	     whotab.e (ute.whotabx).idcode = ute.tty_id_code;
	end;
	ute.destroy_flag = WAIT_LOGOUT_SIG;

/**** Setup login_server_process_response */
	ls_response_ptr = P_ls_response_ptr;
	ls_process_response_accounting_message_length = 0;
	unspec (login_server_process_response) = ""b;
	login_server_process_response.header.message_type = LS_PROCESS_RESPONSE;
	login_server_process_response.header.version = LOGIN_SERVER_PROCESS_RESPONSE_VERSION_1;
	login_server_process_response.status_code = 0;
	login_server_process_response.process_id = ute.proc_id;
	login_server_process_response.new_handle = ute.login_server_info.our_handle;
	login_server_process_response.authorization = ute.process_authorization;
	call ioa_$rsnnl ("^a.^a.^a",
	     login_server_process_response.process_group_id, (0),
	     ute.person, ute.project, ute.tag);
	login_server_process_response.process_number = process_number;
	login_server_process_response.n_disconnected_processes =
	     ute.pdtep -> user.n_disconnected;
	login_server_process_response.start_event_channel = ute.sus_channel;
	login_server_process_response.initial_ring = ute.initial_ring;

/**** login_server_process_response.flags must be set by our caller since we
      don't know the caller's true intention.  He may be reconnecting to do
      a new_proc, to destroy the process, or to continue operation in the 
      suspended process.  This corresponds to different flag settings.       */

	P_ls_response_lth = currentsize (login_server_process_response);
RETURN:
	if uc_disconnected_process_list_ptr ^= null () then
	     free uc_disconnected_process_list in (system_area);
	P_code = code;
	return;

FAULT_LABEL:
	code = as_error_table_$dialup_error;
	goto RETURN;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Stop reconnection by returning nonzero code to our caller.  No    */
/* log message is produced.					       */
/*							       */
/* Syntax:  call Abort (code);				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


Abort:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

	code = P_code;
	goto RETURN;
     end Abort;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort_With_Error:  Stop reconnection by emitting an explanatory as log    */
/* message, and returning nonzero code to our caller.		       */
/*							       */
/* Syntax:  call Abort_With_Error (severity, code, ioa_ctl, args);	       */
/*							       */
/*							       */
/* Error_No_Abort: Add error message to as log, but do not stop	       */
/* reconnection.						       */
/*							       */
/* Syntax:  call Error_No_Abort (severity, code, ioa_ctl, args);	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Abort_With_Error:
     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.arg_list_ptr = cu_$arg_list_ptr();
	sl_info.caller = ME;
	call sys_log_$general (addr(sl_info));
	code = sl_info.code;
	go to RETURN;

Error_No_Abort:
	entry options (variable);
	
     	sl_info = sl_info_sev_code_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr();
	sl_info.caller = ME;
	call sys_log_$general (addr(sl_info));
     end Abort_With_Error;

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


Setup_Outer_Module:
     procedure ();

	if login_server_process_request.outer_module ^= "" then
	     if ^ute.at.vinitproc then
		call Abort (as_error_table_$illegal_om_arg);
	     else ute.outer_module =
		login_server_process_request.outer_module;
	else if ute.outer_module = ute.pdtep -> user.outer_module then;
	else if ute.outer_module = as_data_$tty_dim then do;
	     if login_server_process_request.default_io_module ^= "" then
		ute.outer_module =
		login_server_process_request.default_io_module;
	end;
	return;
     end Setup_Outer_Module;

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


/* format: off */
 %include as_data_;
 %include access_audit_bin_header; /* not used by needed by PL/I */
 %include as_audit_structures;
 %include dialup_values;
 %include login_server_messages;
 %include ls_request_server_info;
 %include pdt;

dcl  pdtp		        ptr automatic init (null);	/* pdt needs it. */
 %include sys_log_constants;
 %include uc_disc_proc_list;
 %include user_attributes;
 %include user_table_entry;
 %include whotab;

end uc_setup_process_connect_;




		    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
