



		    login_server_.pl1               08/04/87  1514.1rew 08/04/87  1222.2      282987



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

/****^  HISTORY COMMENTS:
  1) change(85-03-01,Coren), approve(87-06-25,MCR7679), audit(87-02-28,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-02-28,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations, cleanup handler errors.
      B) Pass ls_ssu_info.(login connect)_info_dir on to endpoint control
         points.
      C) Add list_endpoints (lsep) request to login server.
      D) Change quit request to work correctly if ls_ssu_info.n_endpoints
         ever goes negative.
      E) Make call to login_service_entries.stop_listen work correctly.
         (I'm not sure how this problem was fixed, but it was.) (dsa 73)
  3) change(87-04-13,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Correct overlength comments.
  4) change(87-05-08,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Change control point comments to include endpoint name as well as
     connection name, since same Login Server process may be listening to
     several endpoints which provide indistinguishable connection names.
  5) change(87-05-08,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Add the endpoints_listening request.
  6) change(87-05-14,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Correct control point comments.
  7) change(87-05-18,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
      A) Use new calling sequence of login_service_entries.listen.
      B) Set ls_connection_desc.minimum_ring.
  8) change(87-06-08,GDixon), approve(87-06-25,MCR7679),
     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
      A) Correct declaration of rv, the active request return value.
  9) change(87-06-25,GDixon), approve(87-06-25,MCR7679),
     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
      A) Add trace calls to record errors from control points.
      B) Check ls_ssu_info.call_probe before entering probe upon error from
         control points.
      C) Print "Entering probe:" when probe is called, to make it more
         obvious that probe has been entered.
                                                   END HISTORY COMMENTS */

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

login_server_:
     procedure ();

	return;					/* main entry point is never used */

/* subroutine that processes requests issued to login server. The "start_service" and "stop_service"
   entrypoints are invoked via ssu_$listen. The "listen" entry point is the initial procedure
   for the control point that listens on a given endpoint.
*/

/* PARAMETERS */

dcl  a_sci_ptr pointer parameter;
dcl  a_info_ptr pointer parameter;


/* AUTOMATIC */

dcl  access_class_range (2) bit (72) aligned;
dcl  af_sw bit(1) aligned;
dcl  arg_count fixed bin;
dcl  attach_description char (512) varying;
dcl  code fixed bin (35);
dcl  connection_gone_event_channel fixed bin (71);
dcl  connection_handle fixed bin (35);
dcl  connection_info_len fixed bin (18) unsigned;
dcl  connection_info_ptr pointer;
dcl  connection_name char (32);
dcl  control_point_id bit (36) aligned;
dcl  disconnect_event_channel fixed bin (71);
dcl  endpoint_name char (32);
dcl  ep_found bit (1);
dcl  event_wait_info_ptr pointer;
dcl  last_endpoint_p pointer;
dcl  last_listen_failure_time fixed bin (71);
dcl  minimum_ring fixed bin;
dcl  n_listening fixed bin;
dcl  n_listen_failures fixed bin;
dcl  print_error_event_channel fixed bin (71);
dcl  quit_ok bit (1);
dcl  reply_error_event_channel fixed bin (71);
dcl  rv_len fixed bin(21);
dcl  rv_ptr ptr;
dcl  sci_ptr pointer;
dcl  time_now fixed bin (71);

/* AUTOMATIC STRUCTURES */

dcl  1 auto_event_channel aligned like event_wait_channel;

dcl  1 auto_ipc_create_arg aligned like ipc_create_arg_structure;

/* BASED */

dcl  rv char (rv_len) varying based (rv_ptr);
dcl  system_area area based (system_areap);

/* ENTRIES */

dcl  command_query_$yes_no entry () options (variable);
dcl  dsa_log_manager_$trace_message entry options (variable);
dcl  get_process_id_ entry () returns (bit (36));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ioa_ entry() options(variable);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_event_channel entry (pointer, fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  login_server_connection_ entry (pointer);
dcl  login_server_$listen entry (pointer);
dcl  net_info_$get_service_entries entry (char (*), char (*), pointer, fixed bin (35));
dcl  probe entry options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$print_message entry () options (variable);
dcl  ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21));
dcl  ssu_requests_$quit entry (ptr, ptr);

/* EXTERNAL STATIC */

dcl  (
     error_table_$listen_stopped,
     error_table_$wrong_no_of_args
     ) fixed bin (35) external static;

dcl  iox_$error_output pointer external static;


/* INTERNAL STATIC */

dcl  system_areap pointer internal static initial (null ());

dcl  NORMAL_PRIORITY fixed bin internal static options (constant) initial (1);
dcl  ERROR_PRIORITY fixed bin internal static options (constant) initial (1);
dcl  OUR_NAME char (13) internal static options (constant) initial ("login_server_");
dcl  MAX_LISTEN_FAILURES fixed bin internal static options (constant) initial (4);
dcl  LISTEN_FAILURE_TIME_LIMIT fixed bin (71) internal static options (constant) initial (60 * 1000000);
						/* one minute */


/* BUILTINS & CONDITIONS */

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

dcl  cleanup condition;
%page;
start_service:
     entry (a_sci_ptr, a_info_ptr);

/* "start_login_service" request: sets up a control point to listen on the specified endpoint */

	sci_ptr = a_sci_ptr;
	ls_ssu_info_ptr = a_info_ptr;

	call Setup (ep_found);

	if ep_found
	then if ls_endpoint_list.awaiting_destruction
	     then do;				/* not active at the moment, tell it to start up again */
		call hcs_$wakeup ((get_process_id_ ()), ls_endpoint_list.restart_event_channel, 0, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Could not send wakeup to restart ^a", endpoint_name);
		return;				/* that's it for this request */
	     end;

	     else call ssu_$abort_line (sci_ptr, 0, "login service has already been started for ^a", endpoint_name);

	if system_areap = null ()
	then system_areap = get_system_free_area_ ();
	ccpi_ptr, ls_endpoint_listp, ls_listen_info_ptr = null ();
	on cleanup call Remove_endpoint ();

/* make an entry for it */

	allocate ls_endpoint_list in (system_area) set (ls_endpoint_listp);

	if ls_ssu_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Adding endpoint ^a at ^p.", endpoint_name, ls_endpoint_listp);

	unspec (ls_endpoint_list) = ""b;
	ls_endpoint_list.version = LS_ENDPOINT_LIST_V1;
	ls_endpoint_list.name = endpoint_name;
	ls_endpoint_list.next_endpoint = null ();
	ls_endpoint_list.control_point_id = ""b;
	ls_endpoint_list.service_entries_ptr = null ();

/* add it to tail of list */

	if ls_ssu_info.last_endpoint_ptr = null ()
	then do;
	     ls_ssu_info.first_endpoint_ptr, ls_ssu_info.last_endpoint_ptr = ls_endpoint_listp;
	     ls_endpoint_list.prev_endpoint = null ();
	end;

	else do;
	     last_endpoint_p = ls_ssu_info.last_endpoint_ptr;
	     last_endpoint_p -> ls_endpoint_list.next_endpoint, ls_ssu_info.last_endpoint_ptr = ls_endpoint_listp;
	     ls_endpoint_list.prev_endpoint = last_endpoint_p;
	end;

	ls_ssu_info.n_endpoints = ls_ssu_info.n_endpoints + 1;

/* now set up a control point to listen on it */

	allocate ls_listen_info in (system_area) set (ls_listen_info_ptr);

	ls_listen_info.version = LS_LISTEN_INFO_V1;
	ls_listen_info.sci_ptr = sci_ptr;
	ls_listen_info.ssu_info_ptr = ls_ssu_info_ptr;
	ls_listen_info.endpoint_list_ptr = ls_endpoint_listp;

	ccpi_user_io_attach_desc_length = 0;		/* we're not supplying an attach description */
	allocate create_control_point_info in (system_area) set (ccpi_ptr);

	create_control_point_info.version = CREATE_CONTROL_POINT_INFO_VERSION_1;
	create_control_point_info.comment = rtrim (endpoint_name) ||
	     ": Endpoint Listener";
	create_control_point_info.initproc.entry = login_server_$listen;
	create_control_point_info.initproc.info_ptr = ls_listen_info_ptr;
	create_control_point_info.priority = 1;
	string (create_control_point_info.flags) = ""b;
	create_control_point_info.independent = "1"b;
	create_control_point_info.header.pad = "0"b;

	call cpm_$create (ccpi_ptr, ls_endpoint_list.control_point_id, code);
	free create_control_point_info in (system_area);	/* don't need this any more in any case */

	if code ^= 0
	then do;
	     call Remove_endpoint ();
	     call ssu_$abort_line (sci_ptr, code, "Could not create control point to listen on ^a", endpoint_name);
	end;

	else do;
	     call cpm_$start (ls_endpoint_list.control_point_id, code);

	     if code ^= 0
	     then do;
		call cpm_$destroy (ls_endpoint_list.control_point_id, (0));
		call Remove_endpoint ();
		call ssu_$abort_line (sci_ptr, code, "Could not start control point to listen on ^a", endpoint_name);
	     end;
	end;

	return;					/* all done with start_login_service */
%page;
stop_service:
     entry (a_sci_ptr, a_info_ptr);

/* "stop_login_service" request: stop listening on a specified andpoint */

	sci_ptr = a_sci_ptr;
	ls_ssu_info_ptr = a_info_ptr;
	ccpi_ptr, ls_endpoint_listp, ls_listen_info_ptr = null ();

	call Setup (ep_found);

	if ^ep_found
	then call ssu_$abort_line (sci_ptr, 0, "^a is not active.", endpoint_name);

	login_service_entries_ptr = ls_endpoint_list.service_entries_ptr;
	if system_areap = null ()
	then system_areap = get_system_free_area_ ();

	if login_service_entries_ptr ^= null ()
	then do;

	     call login_service_entries.stop_listen (endpoint_name, code);

	     if code ^= 0
	     then do;
		call ssu_$print_message (sci_ptr, code, "Could not send stop_listen to ^a", endpoint_name);

		if ls_endpoint_list.n_connections = 0
		then do;
		     call cpm_$destroy (ls_endpoint_list.control_point_id, code);
						/* if the stop_listen succeeds, */
		     if ls_ssu_info.trace		/* it will destroy itself when it gets the wakeup */
		     then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code,
			     null (), 0, "", "Destroying control point ^.3b", ls_endpoint_list.control_point_id);
		end;
	     end;
	end;

	else if ls_endpoint_list.control_point_id ^= ""b
	then do;
	     call cpm_$destroy (ls_endpoint_list.control_point_id, code);

	     if ls_ssu_info.trace
	     then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0,
		     "", "Destroying control point ^.3b", ls_endpoint_list.control_point_id);

	     call Remove_endpoint ();			/* take it out of the list */
	end;

	return;					/* done with stop_login_service */
%page;
quit:
     entry (a_sci_ptr, a_info_ptr);

/* "quit" request exits the login server. If there are any outstanding endpoints,
   and more particularly, active connections, the user may not really want to do
   this, so we will ask. If there aren't, or he says yes, pass it on to the standard
   ssu_ quit request.
*/

	sci_ptr = a_sci_ptr;
	ls_ssu_info_ptr = a_info_ptr;

	if ls_ssu_info.n_endpoints <= 0
	then quit_ok = "1"b;			/* we weren't doing anything anyway */

	else do;
	     call ssu_$print_message (sci_ptr, 0, "The following endpoints are active:");

	     do ls_endpoint_listp = ls_ssu_info.first_endpoint_ptr repeat (ls_endpoint_list.next_endpoint)
		while (ls_endpoint_listp ^= null ());
		call ssu_$print_message (sci_ptr, 0, "^-^a (^d connections)", ls_endpoint_list.name,
		     ls_endpoint_list.n_connections);
	     end;

	     call command_query_$yes_no (quit_ok, 0, OUR_NAME,
		"Outstanding connections will not be cleaned up properly.", "Do you want to quit?");
	end;

	if quit_ok
	then call ssu_requests_$quit (sci_ptr, ls_ssu_info_ptr);
	else call ssu_$print_message (sci_ptr, 0,
	     "Please use stop_login_service to stop listening to the endpoints.");

	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This entry returns/prints a count of endpoints being listened to.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

endpoints_listening:
     entry (a_sci_ptr, a_info_ptr);
     
	sci_ptr = a_sci_ptr;
	ls_ssu_info_ptr = a_info_ptr;
	
	call ssu_$return_arg (sci_ptr, arg_count, af_sw, rv_ptr, rv_len);

	n_listening = 0;
	if ls_ssu_info.n_endpoints ^= 0
	then do;
	     do ls_endpoint_listp = ls_ssu_info.first_endpoint_ptr repeat (ls_endpoint_list.next_endpoint)
		while (ls_endpoint_listp ^= null);
	          if ^ls_endpoint_list.awaiting_destruction
		then n_listening = n_listening + 1;
	     end;
	end;

          if af_sw
	then if n_listening > 0
	     then rv = "true";
	     else rv = "false";
	else call ioa_ ("^d ^[endpoint is^;endpoints are^] listening.",
	     n_listening, n_listening = 1);
	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*						         	       */
/* This entry lists endpoints which have been started, and those which have  */
/* subsequently been stopped but are still awaiting destruction.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

list_endpoints:
     entry (a_sci_ptr, a_info_ptr);

	sci_ptr = a_sci_ptr;
	ls_ssu_info_ptr = a_info_ptr;
	
	if ls_ssu_info.n_endpoints = 0
	then call ioa_ ("No endpoints are active.^/");
	else do;
	     call ioa_ ("End Point Name^33tComments");
	     do ls_endpoint_listp = ls_ssu_info.first_endpoint_ptr repeat (ls_endpoint_list.next_endpoint)
		while (ls_endpoint_listp ^= null);
		call ioa_ ("^32a ^3d connections^[, end point stopped^]", ls_endpoint_list.name,
		     ls_endpoint_list.n_connections, ls_endpoint_list.awaiting_destruction);
	     end;
	end;
	return;
%page;
listen:
     entry (a_info_ptr);

/* This entry is invoked as the initial procedure of a control point created to listen on a particular endpoint.
   It issues a "listen" call, which goes blocked until a connection is established,
   whereupon a new control point is created to engage in dialogue over that particular connection
   (and ultimately to assign the connection to a user process, if appropriate).
   Having created such a control point, it goes back and issues another listen.
   This loop continues until and unless the listen call returns a non-zero status code.
*/

	ls_listen_info_ptr = a_info_ptr;
	sci_ptr = ls_listen_info.sci_ptr;
	ls_ssu_info_ptr = ls_listen_info.ssu_info_ptr;
	ls_endpoint_listp = ls_listen_info.endpoint_list_ptr;
	ccpi_ptr = null ();
	if system_areap = null ()
	then system_areap = get_system_free_area_ ();

	on cleanup call Remove_endpoint ();

	endpoint_name = ls_endpoint_list.name;

	auto_ipc_create_arg.version = ipc_create_arg_structure_v1;
	auto_ipc_create_arg.channel_type = CALL_EVENT_CHANNEL_TYPE;
	auto_ipc_create_arg.call_entry = error_message_handler;
	auto_ipc_create_arg.call_data_ptr = null ();
	auto_ipc_create_arg.call_priority = ERROR_PRIORITY;

	call ipc_$create_event_channel (addr (auto_ipc_create_arg), print_error_event_channel, code);
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not create event channel for error messages.");
	     call Remove_endpoint ();
	     return;
	end;

	auto_ipc_create_arg.channel_type = WAIT_EVENT_CHANNEL_TYPE;
	call ipc_$create_event_channel (addr (auto_ipc_create_arg), reply_error_event_channel, code);
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not create reply event channel for error messages.");
	     call Remove_endpoint ();
	     return;
	end;

	allocate login_service_entries in (system_area) set (login_service_entries_ptr);
	login_service_entries.version = LS_ENTRIES_V1;

	call net_info_$get_service_entries ("login_service", endpoint_name, login_service_entries_ptr, code);

	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not get service entries for ^a", endpoint_name);
	     call Remove_endpoint ();
	     return;				/* thus destroying the current control point */
	end;
	auto_ipc_create_arg.channel_type = CALL_EVENT_CHANNEL_TYPE;
	auto_ipc_create_arg.call_entry = Connection_gone_handler;
	auto_ipc_create_arg.call_data_ptr = ls_endpoint_listp;
	auto_ipc_create_arg.call_priority = NORMAL_PRIORITY;
	call ipc_$create_event_channel (addr (auto_ipc_create_arg), connection_gone_event_channel, code);

	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not create connection_gone event channel for ^a",
		endpoint_name);
	     call Remove_endpoint;
	     return;
	end;

	auto_ipc_create_arg.channel_type = WAIT_EVENT_CHANNEL_TYPE;
	call ipc_$create_event_channel (addr (auto_ipc_create_arg), ls_endpoint_list.restart_event_channel, code);

	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not create restart event channel for ^a", endpoint_name);
	     call Remove_endpoint;
	     return;
	end;

	ls_endpoint_list.service_entries_ptr = login_service_entries_ptr;

/* Here's the listen loop. Until something makes us stop, we will come back here
   to listen after passing off each established connection. If a listen fails for some
   reason other than a stop_login_service request (which causes the code error_table_$listen_stopped
   to be returned), we will try it again until we get MAX_LISTEN_FAILURES within LISTEN_FAILURE_TIME_LIMIT.
*/

CALL_LISTEN:
	last_listen_failure_time = 0;
	n_listen_failures = 0;

	auto_ipc_create_arg.channel_type = WAIT_EVENT_CHANNEL_TYPE;
	call ipc_$create_event_channel (addr (auto_ipc_create_arg), disconnect_event_channel, code);
						/* dialogue control point may convert */
						/*  this to an event call channel */
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not create disconnect event channel for ^a", endpoint_name);
	     call Remove_endpoint ();
	     return;				/* and die */
	end;

RETRY_LISTEN:
	call login_service_entries.listen (
	     endpoint_name, system_areap, disconnect_event_channel,
	     connection_name, connection_handle, connection_info_ptr,
	     connection_info_len, attach_description, access_class_range,
	     minimum_ring, code);

	if ls_ssu_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0, "",
		"Listen on ^a.", endpoint_name);

	if code ^= 0
	then do;

/* if code indicates that this is the result of a "stop_listen" request, all is cool */

	     if code ^= error_table_$listen_stopped	/* otherwise, it's worth reporting */
	     then do;
		call ssu_$print_message (sci_ptr, code, "Listen failed on ^a", endpoint_name);

		time_now = clock ();		/* and possibly retrying */
		if time_now - last_listen_failure_time > LISTEN_FAILURE_TIME_LIMIT
		then do;				/* hasn't been one in a while, start count */
		     last_listen_failure_time = time_now;
		     n_listen_failures = 1;
		     go to RETRY_LISTEN;
		end;

		else do;				/* how many have there been? */
		     if n_listen_failures < MAX_LISTEN_FAILURES
		     then do;			/* not too many yet */
			n_listen_failures = n_listen_failures + 1;
			go to RETRY_LISTEN;
		     end;

		     else call ssu_$print_message (sci_ptr, 0, "Too many listen failures. Abandoning endpoint ^a.",
			     endpoint_name);	/* guess it's hopeless. */
		end;				/* fall through to code to wrap up endpoint */
	     end;

/* if there are any outstanding connections created for this endpoint, we can't
   go away yet; so check, and if so, just wait (they'll wake us up when they're
   about to die) */

	     if ls_endpoint_list.n_connections > 0
	     then do;
		ls_endpoint_list.awaiting_destruction = "1"b;
		auto_event_channel.channel_id = ls_endpoint_list.restart_event_channel;
		call ipc_$block (addr (auto_event_channel), event_wait_info_ptr, code);

/* if a fresh start_login_service request is entered for this endpoint while we're waiting,
   we'll just go back and listen again */

		ls_endpoint_list.awaiting_destruction = "0"b;
						/* new lease on life */
		go to CALL_LISTEN;
	     end;

DESTROY_CP:					/* connection_gone_handler branches here */
	     call Remove_endpoint ();			/* if the connection count goes to 0 */
	     if ls_ssu_info.trace
	     then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		     "Return from control point ^.3b (endpoint ^a).", get_control_point_id_ (), endpoint_name);

	     return;				/* THIS IS NORMAL EXIT */
	end;

/* we have a connection now, so set up all the info for the control point */

	revert cleanup;
	ccpi_ptr, ls_error_info_ptr, ls_cp_info_ptr, ls_connection_desc_ptr = null ();
	on cleanup call Remove_connection ();

	allocate ls_connection_desc in (system_area) set (ls_connection_desc_ptr);

	if ls_ssu_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Added connection ^a at ^p.", connection_name, ls_connection_desc_ptr);

	ls_connection_desc.version = LS_CONNECTION_DESC_V1;
	ls_connection_desc.name = connection_name;
	ls_connection_desc.endpoint_name = endpoint_name;
	if attach_description ^= ""
	then ls_connection_desc.io_module = before (attach_description, " ");
	else ls_connection_desc.io_module = "";
	ls_connection_desc.connection_handle = connection_handle;
	ls_connection_desc.disconnect_event_channel = disconnect_event_channel;
	ls_connection_desc.service_entries_ptr = login_service_entries_ptr;
	ls_connection_desc.connection_info_ptr = connection_info_ptr;
	ls_connection_desc.connection_info_len = connection_info_len;
	ls_connection_desc.access_class_range = access_class_range;
	ls_connection_desc.minimum_ring = minimum_ring;
	ls_connection_desc.terminate_event_channel = 0;
	ls_connection_desc.process_info_ptr = null ();

	allocate ls_cp_info in (system_area) set (ls_cp_info_ptr);

	ls_cp_info.version = LS_CP_INFO_V1;
	ls_cp_info.connection_desc_ptr = ls_connection_desc_ptr;
	ls_cp_info.error_event_channel = print_error_event_channel;
	ls_cp_info.connection_gone_event_channel = connection_gone_event_channel;
	string (ls_cp_info.flags) = ""b;
	ls_cp_info.flags = ls_ssu_info.flags, by name;
	ls_cp_info.no_io_switches = (attach_description = "");
	ls_cp_info.answer_table_ptr = ls_ssu_info.answer_table_ptr;
	ls_cp_info.installation_parms_ptr = ls_ssu_info.installation_parms_ptr;
	ls_cp_info.login_info_dir = ls_ssu_info.login_info_dir;
	ls_cp_info.connect_info_dir = ls_ssu_info.connect_info_dir;

	allocate ls_error_info in (system_area) set (ls_error_info_ptr);
	ls_cp_info.error_info_ptr = ls_error_info_ptr;
	ls_error_info.version = LS_ERROR_INFO_V1;
	ls_error_info.reply_event_channel = reply_error_event_channel;
	ls_error_info.caller_name, ls_error_info.error_message = "";

	ccpi_user_io_attach_desc_length = length (rtrim (attach_description));
	allocate create_control_point_info in (system_area) set (ccpi_ptr);

	create_control_point_info.version = CREATE_CONTROL_POINT_INFO_VERSION_1;
	create_control_point_info.comment = rtrim(ls_endpoint_list.name) ||
	     ": " || rtrim(connection_name) || " login dialogue";
	create_control_point_info.initproc.entry = login_server_connection_;
	create_control_point_info.initproc.info_ptr = ls_cp_info_ptr;
	create_control_point_info.priority = 1;
	string (create_control_point_info.flags) = ""b;
	create_control_point_info.independent = "1"b;
	if attach_description ^= ""
	then do;
	     create_control_point_info.separate_standard_iocbs = "1"b;
	     create_control_point_info.user_io_attach_desc_given = "1"b;
	end;

	create_control_point_info.header.pad = ""b;
	create_control_point_info.user_io_attach_desc = attach_description;

	call cpm_$create (ccpi_ptr, control_point_id, code);
	free create_control_point_info in (system_area);

	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not create control point for dialogue on ^a",
		connection_name);
	     call Remove_connection ();
	end;

	else do;
	     revert cleanup;
	     call cpm_$start (control_point_id, code);
	     if code ^= 0
	     then do;
		call ssu_$print_message (sci_ptr, "Could not start control point for dialogue on ^a", connection_name)
		     ;
		call cpm_$destroy (control_point_id, (0));
						/* we don't have much use for this any more */
		call Remove_connection ();
	     end;

	     else ls_endpoint_list.n_connections = ls_endpoint_list.n_connections + 1;
	end;

	go to CALL_LISTEN;				/* go around again to listen for another connection */
%page;
error_message_handler:
     entry (a_info_ptr);

/* event call handler for printing error messages intended for the daemon, but
   generated by control points for the individual connections. The event message
   is actually a pointer to the ls_cp_info. The calling control point waits for
   a wakeup from this handler before resuming.
*/

	event_call_info_ptr = a_info_ptr;
	unspec (ls_cp_info_ptr) = unspec (event_call_info.message);
	ls_error_info_ptr = ls_cp_info.error_info_ptr;
	ls_connection_desc_ptr = ls_cp_info.connection_desc_ptr;

	call ioa_$ioa_switch (iox_$error_output, "^a (^a): ^a", ls_error_info.caller_name, ls_connection_desc.name,
	     substr (ls_error_info.error_message, 1, ls_error_info.error_message_length));

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
	     "Error: ^a (^a): ^a", ls_error_info.caller_name, ls_connection_desc.name,
	     substr (ls_error_info.error_message, 1, ls_error_info.error_message_length));

	if ls_cp_info.call_probe
	then do;
	     call ioa_$ioa_switch (iox_$error_output, "Entering probe:^/");
	     call probe ();
	end;

/* tell calling control point it's OK to run again */

	call hcs_$wakeup (event_call_info.sender, ls_error_info.reply_event_channel, 0, (0));
	return;
%page;
Connection_gone_handler:
     procedure (a_info_ptr);

/* event call handler invoked when a child control point is on the way out and has
   deleted its connection. This allows us to decrement the count of outstanding
   connections; if it goes to 0 and we were waiting to be able destroy ourselves,
   then we will do so. */

dcl  a_info_ptr pointer parameter;
dcl  ls_end_listp pointer;
dcl  1 ls_end_list aligned like ls_endpoint_list based (ls_end_listp);

	event_call_info_ptr = a_info_ptr;
	ls_end_listp = event_call_info.data_ptr;	/* set our own pointer to ls_endpoint_list struct */

	ls_end_list.n_connections = ls_end_list.n_connections - 1;
	if ls_end_list.n_connections <= 0
	then if ls_end_list.awaiting_destruction
	     then go to DESTROY_CP;			/* we can wrap it up now */

	return;					/* otherwise, as you were */
     end Connection_gone_handler;
%page;
Setup:
     procedure (found);

/* Process the request argument and find out if the specified endpoint is listed already. */

/* This procedure sets the outer block's variables "endpoint_name" and "ls_endpoint_listp" */

dcl  found bit (1) parameter;

dcl  cur_ls_endpoint_listp ptr;
dcl  nargs fixed bin;
dcl  argp pointer;
dcl  argl fixed bin (21);
dcl  arg char (argl) based (argp);


	call ssu_$arg_count (sci_ptr, nargs);
	if nargs ^= 1
	then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args, "Usage: start_login_service ENDPOINT_NAME");

	call ssu_$arg_ptr (sci_ptr, 1, argp, argl);

	endpoint_name = arg;
	found = "0"b;
	ls_endpoint_listp = null ();

/* see if the specified endpoint is in the list of active ones */

	if ls_ssu_info.n_endpoints ^= 0
	then do cur_ls_endpoint_listp = ls_ssu_info.first_endpoint_ptr
		repeat (cur_ls_endpoint_listp -> ls_endpoint_list.next_endpoint)
		while ((cur_ls_endpoint_listp ^= null ()) & (^found));
	     if cur_ls_endpoint_listp -> ls_endpoint_list.name = endpoint_name
	     then do;
		found = "1"b;
		ls_endpoint_listp = cur_ls_endpoint_listp;
	     end;
	end;

	return;

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

/* take the endpoint list entry pointed to by ls_endpoint_ptr out of the list */

dcl  prev_ptr pointer;

	if ls_ssu_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Removing endpoint ^a at ^p.", ls_endpoint_list.name, ls_endpoint_listp);

	if ccpi_ptr ^= null ()
	then free create_control_point_info in (system_area);

	if ls_listen_info_ptr ^= null ()
	then free ls_listen_info in (system_area);

	if ls_endpoint_listp = null
	then return;

	prev_ptr = ls_endpoint_list.prev_endpoint;
	if prev_ptr = null ()
	then ls_ssu_info.first_endpoint_ptr = ls_endpoint_list.next_endpoint;
	else prev_ptr -> ls_endpoint_list.next_endpoint = ls_endpoint_list.next_endpoint;

	if ls_endpoint_list.next_endpoint = null ()
	then ls_ssu_info.last_endpoint_ptr = prev_ptr;
	else ls_endpoint_list.next_endpoint -> ls_endpoint_list.prev_endpoint = prev_ptr;

	if ls_endpoint_list.service_entries_ptr ^= null ()
	then free ls_endpoint_list.service_entries_ptr -> login_service_entries in (system_area);
	free ls_endpoint_list in (system_area);

	ls_ssu_info.n_endpoints = ls_ssu_info.n_endpoints - 1;
	return;

     end Remove_endpoint;
%page;
Remove_connection:
     procedure ();

/* close a connection that couldn't be run, and free the storage associated with it. */

	if ls_cp_info_ptr ^= null ()
	then do;
	     if ls_error_info_ptr ^= null ()
	     then free ls_error_info in (system_area);
	     free ls_cp_info in (system_area);
	end;

	if ccpi_ptr ^= null ()
	then free create_control_point_info in (system_area);

	if ls_ssu_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Removing connection ^a at ^p.", connection_name, ls_connection_desc_ptr);

	call login_service_entries.disconnect (connection_name, connection_handle, ""b, (0));
	call ipc_$delete_ev_chn (disconnect_event_channel, (0));

	if ls_connection_desc_ptr ^= null
	then free ls_connection_desc in (system_area);

	return;

     end Remove_connection;
%page;
%include ls_ssu_info;
%page;
%include ls_listen_info;
%page;
%include ls_connection_desc;
%page;
%include ls_cp_info;
%page;
%include ls_error_info;
%page;
%include login_service_entries;
%page;
%include dsa_log_constants;
%page;
%include cpm_entries;
%page;
%include cpm_create_ctrl_pt_info;
%page;
%include event_call_info;
%page;
%include ipc_create_arg;
%page;
%include event_wait_channel;

     end login_server_;




		    login_server_connection_.pl1    08/04/87  1514.1rew 08/04/87  1222.2      307089



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

/****^  HISTORY COMMENTS:
  1) change(85-04-01,Coren), approve(87-06-25,MCR7679), audit(87-03-02,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-02,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations.
      B) Add any_other handler to take lsdump, then remove the connection.
  3) change(87-04-16,Brunelle), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Add ls_process_info.process_group_id to call to assign_connection.
  4) change(87-04-29,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Change calling sequence of ls_dump_.
  5) change(87-05-08,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Give login_service_entries.assign_connection the initializer_handle rather
     than the server_handler; this allows the network to send Initializer a
     disconnect if Login_Server process dies.
  6) change(87-05-15,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Ignore io_error that occurs when attempting to display "hangup" message
     upon process termination, when line has already disconnected.
  7) change(87-05-18,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
      A) Use new calling sequence of login_service_entries.listen.
      B) Set ls_connection_desc.minimum_ring.
      C) Use revised calling sequence for login_server_entries.validate_user.
  8) change(87-05-26,GDixon), approve(87-06-25,MCR7679),
     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
      A) Use new calling sequence of ls_report_subr_error_.  Avoid taking LS
         dumps for "expected" errors.
      B) Avoid printing on terminal when io_error condition has been signalled.
      C) Avoid reference to ls_connection_desc_ptr when it is null.
  9) change(87-06-18,GDixon), approve(87-06-25,MCR7679),
     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
      A) Avoid infinite loop when an io_error condition occurs while in
         debug_mode.
      B) Don't send disconnect request to Initializer after receiving a
         terminate response from the Initializer.
 10) change(87-06-25,GDixon), approve(87-06-25,MCR7679),
     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
      A) Call ls_report_subr_error_ and dsa_manager_$trace_message to report
         problems in disconnecting a connection.
                                                   END HISTORY COMMENTS */

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

login_server_connection_:
     procedure (a_info_ptr);

/* This is the initial procedure for the control point that manages a single connection
   talking to the login server. It calls validate_user_ to engage in the login
   dialogue with the user and the Initializer; assuming this succeeds, it sets up handlers for
   disconnection and process termination, wakes up the user process, and blocks
   until one of the above events takes place. The control point lasts as long as
   the connection does.
*/

/* DECLARATIONS */

dcl  a_info_ptr pointer parameter;


/* AUTOMATIC */

dcl  code fixed bin (35);
dcl  connection_name char (32);
dcl  cpu_minutes fixed bin;
dcl  cpu_seconds fixed bin;
dcl  dumpid char (128) varying;
dcl  error_message char (100) aligned;
dcl  event_message fixed bin (71);
dcl  fatal_condition bit (1);
dcl  got_response bit (1);
dcl  message_type fixed bin;
dcl  person char (22);
dcl  person_project char (30);
dcl  project char (9);
dcl  tell_user bit (1) aligned;
dcl  terminate_event_channel fixed bin (71);
dcl  trace_switch bit (1);
dcl  validate_code fixed bin (35);


/* AUTOMATIC COPIES OF STRUCTURES */

dcl  1 auto_disconnect_request aligned like login_server_disconnect_request;

dcl  1 auto_event_wait_info aligned like event_wait_info;

dcl  1 auto_process_info aligned like ls_process_info;

dcl  1 auto_user_message_add_info aligned like as_user_message_add_info;

dcl  1 auto_user_message_info aligned like as_user_message_info;

dcl  1 auto_validate_options aligned like ls_validate_options;


/* BASED */

dcl  based_connection_info (ls_connection_desc.connection_info_len) bit (36) aligned based;

dcl  system_area area based (system_areap);

dcl  user_message (as_user_message_info.message_length) bit (36) aligned based (ls_response_ptr);


/* ENTRIES */

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  dsa_log_manager_$trace_message entry options (variable);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  get_process_id_ entry () returns (bit (36));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ls_convert_as_error_code_ entry (fixed bin (35)) returns (fixed bin (35));
dcl  ls_dump_ entry (char(*) var, ptr, char(32));
dcl  ls_message_$print entry options (variable);
dcl  ls_message_$print_error entry options (variable);
dcl  ls_report_internal_error_ entry options (variable);
dcl  ls_report_subr_error_ entry (fixed bin(35), char(*), ptr, char(*),
	bit(1) aligned, bit(1) aligned);
dcl  send_ls_request_ entry (ptr, fixed bin (18), ptr, fixed bin (35));
dcl  user_message_$read_message entry (pointer, pointer, fixed bin (35));
dcl  user_message_priv_$add_message entry (ptr, fixed bin (35));


/* EXTERNAL STATIC */

dcl  (
     error_table_$action_not_performed,
     error_table_$no_message,
     error_table_$process_unknown,
     error_table_$unimplemented_version,
     ls_message_table_$automatic_logout,
     ls_message_table_$dial_logout,
     ls_message_table_$dial_terminated,
     ls_message_table_$dropped_by_mc,
     ls_message_table_$fatal_error,
     ls_message_table_$fpe_caused_logout,
     ls_message_table_$fpe_during_init,
     ls_message_table_$fpe_loop,
     ls_message_table_$fpe_new_proc,
     ls_message_table_$hangup,
     ls_message_table_$logout,
     ls_message_table_$offer_help
     ) fixed bin (35) external static;


dcl  iox_$user_io pointer external static;


/* INTERNAL STATIC */

dcl  DISCONNECT_EVENT fixed bin internal static options (constant) initial (1);
dcl  DONT_TAKE_DUMP bit (1) aligned int static options(constant) init("0"b);
dcl  DONT_TELL_INITIALIZER bit (1) aligned int static options (constant) init ("0"b);
dcl  DONT_TELL_USER bit (1) aligned int static options (constant) init ("0"b);
dcl (FALSE init ("0"b),
     TRUE init ("1"b)) bit (1) int static options (constant);
dcl  N_WAIT_EVENTS fixed bin internal static options (constant) initial (2);
dcl  ONE_MILLION fixed bin (35) internal static options (constant) initial (1000000);
dcl  OUR_NAME char (12) internal static options (constant) initial ("login_server");
dcl  TAKE_DUMP bit (1) aligned int static options(constant) init("1"b);
dcl  TERMINATE_EVENT fixed bin internal static options (constant) initial (2);
dcl  TELL_INITIALIZER bit (1) aligned int static options (constant) init ("1"b);
dcl  TELL_USER bit (1) aligned int static options (constant) init ("1"b);
dcl  our_process_id bit (36) aligned internal static initial (""b);
dcl  system_areap pointer internal static initial (null ());


/* BUILTINS AND CONDITIONS */

dcl  (addr, after, before, clock, currentsize, divide, length, null, rtrim, size, string, substr, unspec) builtin;

dcl  (any_other, cleanup, io_error) condition;
%page;
	call iox_$control (iox_$user_io, "quit_disable", null (), (0));
						/* we don't want quits while we're in the login server */
	ls_cp_info_ptr = a_info_ptr;
	ls_connection_desc_ptr = ls_cp_info.connection_desc_ptr;
	if system_areap = null ()
	then system_areap = get_system_free_area_ ();
	if our_process_id = ""b
	then our_process_id = get_process_id_ ();
	connection_name = ls_connection_desc.name;
	trace_switch = ls_cp_info.trace;

	event_wait_list_ptr = null ();

	on cleanup call Remove_connection ();
	on any_other
	     begin;
	     ci.version = condition_info_version_1;
	     call find_condition_info_ (null, addr (ci), code);
	     if code = 0
	     then do;
		dumpid = "Condition ";
		dumpid = dumpid || rtrim (ci.condition_name);
		dumpid = dumpid || " in connection";
	     end;
	     else dumpid = "Unknown condition in connection ";
	     if ls_connection_desc_ptr ^= null then do;
		dumpid = dumpid || " ";
		dumpid = dumpid || rtrim (ls_connection_desc.name);
	     end;
	     dumpid = dumpid || ".";
	     fatal_condition = TRUE;
	     if ci.info_ptr ^= null
	     then do;
		condition_info_header_ptr = ci.info_ptr;
		if condition_info_header.action_flags.default_restart
		then fatal_condition = FALSE;
	     end;
	     if fatal_condition
	     then do;
		call ls_dump_ (dumpid, addr (ls_cp_info), "");
		tell_user = (ci.condition_name ^= "io_error") &
		     (ls_connection_desc_ptr ^= null);
		call Hangup_and_remove (tell_user, TELL_INITIALIZER);
	     end;
	end;

	call cpm_$set_user_cl_intermediary (get_control_point_id_ (), Cl_intermediary, code);

	if code ^= 0
	then do;
	     call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		"cpm_$set_user_cl_intermediary", TELL_USER, TAKE_DUMP);
	     call Hangup_and_remove (TELL_USER, DONT_TELL_INITIALIZER);
	     return;
	end;

	ls_process_info_ptr = addr (auto_process_info);
	unspec (ls_process_info) = ""b;
	ls_process_info.version = LS_PROCESS_INFO_V1;
	login_service_entries_ptr = ls_connection_desc.service_entries_ptr;

/* now set up event channel for process termination */

	call ipc_$create_ev_chn (terminate_event_channel, code);
	if code ^= 0
	then do;
	     call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		"ipc_$create_ev_chn", TELL_USER, TAKE_DUMP);
	     call Hangup_and_remove (TELL_USER, DONT_TELL_INITIALIZER);
	     go to EXIT;
	end;

	ls_connection_desc.terminate_event_channel = terminate_event_channel;
	ls_connection_desc.process_info_ptr = ls_process_info_ptr;

	auto_validate_options.version = LS_VALIDATE_OPTIONS_V1;
	string (auto_validate_options.flags) = ""b;


	call login_service_entries.validate_user (ls_cp_info_ptr,
	     addr (auto_validate_options), ls_process_info_ptr, code);

	if code ^= 0
	then do;
	     call Remove_connection ();

	     if trace_switch
	     then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		     "Returning from control point ^.3b, connection ^a.", get_control_point_id_ (), connection_name);

	     return;
	end;

	call Give_connection_to_process ();

/* we will now go blocked until one of the events happens. */

	event_wait_info_ptr = addr (auto_event_wait_info);

	event_wait_list_n_channels = N_WAIT_EVENTS;
	allocate event_wait_list in (system_area) set (event_wait_list_ptr);

	event_wait_list.n_channels = N_WAIT_EVENTS;
	event_wait_list.pad = ""b;
	event_wait_list.channel_id (DISCONNECT_EVENT) = ls_connection_desc.disconnect_event_channel;
	event_wait_list.channel_id (TERMINATE_EVENT) = ls_connection_desc.terminate_event_channel;

	do while ("1"b);
	     call ipc_$block (event_wait_list_ptr, event_wait_info_ptr, code);
	     if code ^= 0
	     then do;
		call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		     "ipc_$block", TELL_USER, TAKE_DUMP);
		call Hangup_and_remove (TELL_USER, DONT_TELL_INITIALIZER);
		go to EXIT;
	     end;

	     if event_wait_info.channel_index = DISCONNECT_EVENT
	     then call Disconnect_handler ();
	     else if event_wait_info.channel_index = TERMINATE_EVENT
	     then call Terminate_handler ();
	     else call ls_report_internal_error_ (0, OUR_NAME, ls_cp_info_ptr, "0"b,
		     "Wakeup with unexpected channel index ^d", event_wait_info.channel_index);

/* whatever it was, go wait for more */

	end;

EXIT:						/* come here from handlers if control point is all finished */
	if trace_switch
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Returning from control point ^.3b, connection ^a.", get_control_point_id_ (), connection_name);

	return;
%page;
Disconnect_handler:
     procedure ();

/* This procedure is invoked when the connection is broken */

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Disconnect wakeup for connection ^a.", connection_name);

	if ls_process_info_ptr ^= null ()
	then do;
	     call Send_disconnect_request ();

	     if ls_process_info.usage_type ^= LS_LOGIN_USAGE
	     then call Send_user_message (LS_MSG_DISCONNECTED, null (), 0);
						/* inform the user process that had the connection */
	end;

	call login_service_entries.disconnect (connection_name, ls_connection_desc.connection_handle, ""b, (0));
						/* in case lower layer needs this */

	call Remove_connection ();
	go to EXIT;

     end Disconnect_handler;
%page;
Terminate_handler:
     procedure ();

/* This procedure is invoked when the user process for this connection terminates.
   It reads the "user_message" from the Initializer, which should be either a new_proc response
   or a termination response, and proceeds accordingly.
*/

	call iox_$control (iox_$user_io, "quit_disable", null (), (0));
						/* we don't want quits while we're in the login server */

	as_user_message_info_ptr = addr (auto_user_message_info);
	as_user_message_info.version = AS_USER_MESSAGE_INFO_VERSION_1;
	string (as_user_message_info.flags) = ""b;
	as_user_message_info.message_handle = ls_process_info.server_handle;
	got_response = "0"b;

	ls_response_ptr = null ();
	on cleanup
	     begin;
	     if ls_response_ptr ^= null ()
	     then free user_message in (system_area);
	end;

	do while (^got_response);
	     call user_message_$read_message (system_areap, as_user_message_info_ptr, code);
	     if code ^= 0
	     then do;
		call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		     "user_message_$read_message", TELL_USER,
		     (code ^= error_table_$no_message));
		call Hangup_and_remove (TELL_USER, TELL_INITIALIZER);
		go to EXIT;
	     end;

	     ls_response_ptr = as_user_message_info.message_ptr;
	     message_type = login_server_response_header.message_type;

	     if ls_cp_info.trace
	     then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		     "Termination message (type ^d) for connection ^a.", message_type, connection_name);

	     if message_type ^= LS_TERMINATION_RESPONSE & message_type ^= LS_NEW_PROC_RESPONSE
	     then do;
		call ls_report_internal_error_ (0, OUR_NAME, ls_cp_info_ptr, "0"b,
		     "Ignoring unexpected message type ^d", message_type);
		free user_message in (system_area);
	     end;


	     else got_response = "1"b;		/* this is for us */
	end;

/* First thing, we know we want to unassign it */

	call login_service_entries
	     .unassign_connection (connection_name, ls_connection_desc.connection_handle, ""b, code);

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0, "",
		"Unassigning connection ^a.", connection_name);

	if code ^= 0
	then call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
	     "unassign_connection", DONT_TELL_USER, DONT_TAKE_DUMP);

	if message_type = LS_TERMINATION_RESPONSE	/* process termination */
	then do;
	     if login_server_termination_response.version ^= LOGIN_SERVER_TERMINATION_RESPONSE_VERSION_1
	     then do;
		call ls_report_internal_error_ (error_table_$unimplemented_version, OUR_NAME, ls_cp_info_ptr, "1"b,
		     "Termination response message contains version ""^a"".",
		     login_server_termination_response.version);
		go to TERMINATE_FINISHED;
	     end;

	     if login_server_termination_response.process_id ^= ls_process_info.process_id
	     then do;
		call ls_report_internal_error_ (0, OUR_NAME, ls_cp_info_ptr, "0"b,
		     "Ignoring termination message for process ^12.3b, expected ^12.3b.",
		     login_server_termination_response.process_id, ls_process_info.process_id);
TERMINATE_FINISHED:
		call Hangup_and_remove (TELL_USER, TELL_INITIALIZER);
		free login_server_termination_response in (system_area);
		go to EXIT;
	     end;

	     if ls_process_info.usage_type = LS_LOGIN_USAGE
	     then do;
		if ^ls_cp_info.no_io_switches
		then do;
		     if login_server_termination_response.fatal_error
						/* fatal error */
		     then do;
			call convert_status_code_ (
			     ls_convert_as_error_code_ (login_server_termination_response.status_code), (""),
			     error_message);
			call ls_message_$print (ls_message_table_$fatal_error, error_message);

			if login_server_termination_response.fpe_caused_logout
			then call ls_message_$print (ls_message_table_$fpe_caused_logout);

			if login_server_termination_response.fpe_during_init
			then call ls_message_$print (ls_message_table_$fpe_during_init);

			if login_server_termination_response.fpe_loop
			then call ls_message_$print (ls_message_table_$fpe_loop);

			ls_process_info.fatal_error = "1"b;
						/* to remember when new process created */
		     end;

		     else if login_server_termination_response.status_code ^= 0
		     then call ls_message_$print_error (
			     ls_convert_as_error_code_ (login_server_termination_response.status_code));

		     if login_server_termination_response.offer_help
		     then call ls_message_$print (ls_message_table_$offer_help);

		     if login_server_termination_response.logout
		     then do;
			if login_server_termination_response.automatic_logout
			then call ls_message_$print (ls_message_table_$automatic_logout);

			if ^login_server_termination_response.brief
			then do;
			     person_project =
				substr (ls_process_info.process_group_id, 1,
				length (rtrim (ls_process_info.process_group_id)) - 2);
			     person = before (person_project, ".");
			     project = after (person_project, ".");
			     cpu_seconds = divide (login_server_termination_response.cpu_usage, ONE_MILLION, 17, 0);
			     cpu_minutes = divide (cpu_seconds, 60, 17, 0);
			     cpu_seconds = cpu_seconds - 60 * cpu_minutes;

			     call ls_message_$print (ls_message_table_$logout, person, project,
				date_time_$format ("system_date_time", clock (), "system_zone", "system_lang"),
				(cpu_minutes ^= 0), cpu_minutes, cpu_seconds,
				login_server_termination_response.cost);
			end;
		     end;
		end;

		if login_server_termination_response.logout
		then do;
		     if ^login_server_termination_response.hold
		     then do;			/* all done */
			call Hangup_and_remove (TELL_USER, DONT_TELL_INITIALIZER);
			validate_code = error_table_$action_not_performed;
						/* to make sure we exit */
		     end;

		     else				/* back into login dialogue to find out what he wants now */
			call Revalidate (login_server_termination_response.brief, validate_code);
		end;

		else validate_code = 0;
	     end;

	     else if ls_process_info.usage_type = LS_DIAL_USAGE
	     then do;
		if ^ls_cp_info.no_io_switches
		then if login_server_termination_response.logout
		     then call ls_message_$print (ls_message_table_$dial_logout);
		     else call ls_message_$print (ls_message_table_$dial_terminated);
		call Revalidate ("0"b, validate_code);
	     end;

	     else if ls_process_info.usage_type = LS_MC_USAGE
	     then do;				/* in this case "termination" really means operator dropped the connection */
		if ^ls_cp_info.no_io_switches
		then call ls_message_$print (ls_message_table_$dropped_by_mc, connection_name);
		call Revalidate ("0"b, validate_code);
	     end;

	     else do;				/* why would we get wakeup for connection that was neither login nor dial? */
		call ls_report_internal_error_ (0, OUR_NAME, ls_cp_info_ptr, "1"b,
		     "Unexpected usage type ^d for process termination", ls_process_info.usage_type);
		call Hangup_and_remove (TELL_USER, TELL_INITIALIZER);
		validate_code = error_table_$action_not_performed;
						/* to make sure we exit */
	     end;

	     free login_server_termination_response in (system_area);
	     if validate_code ^= 0
	     then go to EXIT;
	end;					/* terminate_response */

	else do;					/* must be new_proc */
	     if login_server_new_proc_response.version ^= LOGIN_SERVER_NEW_PROC_RESPONSE_VERSION_1
	     then do;
		call ls_report_internal_error_ (error_table_$unimplemented_version, OUR_NAME, ls_cp_info_ptr, "1"b,
		     "new_proc response message contains version ""^a"".", login_server_new_proc_response.version);
		validate_code = error_table_$action_not_performed;
						/* make sure we exit */
	     end;

	     else do;
		if ls_process_info.fatal_error
		then do;				/* tell him about new process */
		     call ls_message_$print (ls_message_table_$fpe_new_proc);
		     ls_process_info.fatal_error = "0"b;
		end;

		call Start_new_process ();
		validate_code = 0;
	     end;

	     free login_server_new_proc_response in (system_area);

	     if validate_code ^= 0
	     then go to EXIT;

	end;					/* logout_response */

/* if we got to here, we're all done and can go blocked again */

	return;
     end Terminate_handler;
%page;
Cl_intermediary:
     procedure (start_flag);

/* This is called in case of a call to cu_$cl while the current control point is running */

dcl  start_flag bit (1) parameter;

	if ls_cp_info.debug_mode
	then do;
	     ci.version = condition_info_version_1;
	     call find_condition_info_ (null, addr (ci), code);
	     if code = 0
	     then if ci.condition_name ^= "io_error" then do;
		start_flag = "0"b;			/* get to command level so we can poke around */
		return;				/* io_error is fatal, however. */
	     end;
	end;

	if ^ls_cp_info.fault_recursion
	then do;					/* try to clean up if possible */
	     ls_cp_info.fault_recursion = "1"b;		/* in case we get invoked again */
	     if ls_connection_desc_ptr ^= null ()	/* connection still active */
	     then do;
		on io_error go to IGNORE_IO_ERR;	/* Ignore errors due to disconnection. */
		call ls_message_$print (0, "Internal error. Abandoning connection.");
IGNORE_IO_ERR:	revert io_error;
		call Hangup_and_remove (TELL_USER, TELL_INITIALIZER);
	     end;
	end;

	go to EXIT;				/* no more control point */

     end Cl_intermediary;
%page;
Give_connection_to_process:
     procedure ();

/* this procedure assigns the connection to a user process, passes the entity-specific connection_info
   to the process, and wakes the process up
*/


	login_service_entries_ptr = ls_connection_desc.service_entries_ptr;
	ls_process_info_ptr = ls_connection_desc.process_info_ptr;

	call login_service_entries
	     .
	     assign_connection ((ls_connection_desc.name),
	     ls_connection_desc.connection_handle, 
	     ls_process_info.process_id, ls_process_info.process_group_id,
	     ls_process_info.initializer_handle,
	     ls_connection_desc.disconnect_event_channel,
	     ls_connection_desc.terminate_event_channel,
	     ls_process_info.usage_type, code);

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0, "",
		"Assigning connection ^a to process ^.3b.", ls_connection_desc.name, ls_process_info.process_id);

	if code ^= 0
	then do;
	     call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		"assign_connection", TELL_USER, DONT_TAKE_DUMP);
	     call Hangup_and_remove (TELL_USER, TELL_INITIALIZER);
	     go to EXIT;
	end;

	call Send_user_message (LS_MSG_CONNECTED, ls_connection_desc.connection_info_ptr,
	     ls_connection_desc.connection_info_len);

	return;

     end Give_connection_to_process;
%page;
Send_user_message:
     procedure (a_reason, a_info_ptr, a_info_length);

/* Sends a message to the user process to give it the connection, or inform it
   of disconnection, and send the process a wakeup so it knows to read the message. */

dcl  a_reason fixed bin parameter;
dcl  a_info_ptr pointer parameter;
dcl  a_info_length fixed bin (18) unsigned parameter;

dcl  based_connection_info (ls_connection_message_info_length) bit (36) aligned based;

dcl  time_now fixed bin (71);
dcl  unique_part_of_handle bit (54) aligned;


	if a_info_ptr ^= null ()
	then ls_connection_message_info_length = a_info_length;
	else ls_connection_message_info_length = 0;

	ls_connection_message_ptr = null ();
	on cleanup
	     begin;
	     if ls_connection_message_ptr ^= null ()
	     then free ls_connection_message in (system_area);
	end;

	allocate ls_connection_message in (system_area) set (ls_connection_message_ptr);

	unspec (ls_connection_message) = ""b;
	ls_connection_message.version = LS_CONNECTION_MESSAGE_V1;
	ls_connection_message.connection_name = connection_name;
	ls_connection_message.io_module_name = ls_connection_desc.io_module;
	ls_connection_message.connection_handle = ls_connection_desc.connection_handle;
	ls_connection_message.reason = a_reason;
	ls_connection_message.connection_info_length = ls_connection_message_info_length;
	if ls_connection_message.connection_info_length ^= 0
	then ls_connection_message.connection_info = a_info_ptr -> based_connection_info;

	if ls_process_info.usage_type = LS_DIAL_USAGE
	then do;
	     time_now = clock ();
	     unique_part_of_handle = substr (unspec (time_now), 19, 54);
	     call Send_actual_message (size (ls_connection_message_common),
		unique_part_of_handle || USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18);
	end;

	call Send_actual_message (currentsize (ls_connection_message), USER_MESSAGE_LS_CONNECTION_INFO_HANDLE);

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0, "",
		"Sent ^[connect^;disconnect^] message to user process ^.3b for connection ^a.",
		(a_reason = LS_MSG_CONNECTED), ls_process_info.process_id, connection_name);

	free ls_connection_message in (system_area);

	event_message = 0;
	dial_event_message_ptr = addr (event_message);
	if ls_process_info.usage_type = LS_DIAL_USAGE
	then dial_event_message_handle = unique_part_of_handle;
	dial_event_message.ls_msg = "1"b;
	if a_reason = LS_MSG_CONNECTED
	then dial_event_message.control = JUST_DIALED;
	else dial_event_message.control = JUST_HUNGUP;

	call hcs_$wakeup (ls_process_info.process_id, ls_process_info.start_event_channel, event_message, code);
	if code ^= 0
	then call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
	     "hcs_$wakeup", DONT_TELL_USER,
	     (code ^= error_table_$process_unknown));
	return;
%page;
Send_actual_message:
	procedure (a_message_length, a_message_handle);

/* internal to Send_user_message: sets up and makes the actual call to user_message_priv_$add_message */

dcl  a_message_length fixed bin (18) parameter;
dcl  a_message_handle bit (72) aligned parameter;

	     as_user_message_add_info_ptr = addr (auto_user_message_add_info);

	     unspec (as_user_message_add_info) = ""b;
	     as_user_message_add_info.version = AS_USER_MESSAGE_ADD_INFO_VERSION_1;
	     as_user_message_add_info.message_ptr = ls_connection_message_ptr;
	     as_user_message_add_info.message_length = a_message_length;
	     as_user_message_add_info.message_access_class = ls_process_info.authorization;
	     as_user_message_add_info.group_id = "";	/* because we have process id */
	     as_user_message_add_info.process_id = ls_process_info.process_id;
	     as_user_message_add_info.handle = a_message_handle;
	     as_user_message_add_info.ring = ls_process_info.initial_ring;
	     as_user_message_add_info.reader_deletes = "1"b;
						/* we're not going to keep track of it */

	     call user_message_priv_$add_message (as_user_message_add_info_ptr, code);
	     if code ^= 0
	     then call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		"user_message_priv_$add_message", TELL_USER, TAKE_DUMP);
	     return;

	end Send_actual_message;

     end Send_user_message;
%page;
Revalidate:
     procedure (a_brief, a_code);

dcl  a_brief bit (1) parameter;
dcl  a_code fixed bin (35) parameter;

	auto_validate_options.version = LS_VALIDATE_OPTIONS_V1;
	auto_validate_options.brief = a_brief;
	auto_validate_options.not_first = "1"b;
	auto_validate_options.mbz = ""b;

	if ^ls_cp_info.no_io_switches
	then call ioa_ ("");			/* put out blank line */
	call login_service_entries.validate_user (ls_cp_info_ptr,
	     addr (auto_validate_options), ls_process_info_ptr, a_code);

	if a_code ^= 0
	then call Remove_connection ();

	else call Give_connection_to_process ();	/* event channels are still set up from original login */

	return;
     end Revalidate;
%page;
Start_new_process:
     procedure ();

/* This procedure is called after new_proc or fatal error to update ls_process_info
   for the new process and to pass the connection to it */

	ls_process_info.authorization = login_server_new_proc_response.new_authorization;
	ls_process_info.process_id = login_server_new_proc_response.new_process_id;
	ls_process_info.start_event_channel = login_server_new_proc_response.new_start_event_channel;

	call Give_connection_to_process ();
	return;

     end Start_new_process;
%page;
Hangup_and_remove:
     procedure (tell_user, tell_initializer);

/* Disconnect the user, and discard the connection */

dcl  tell_user bit (1) aligned parameter;
dcl  tell_initializer bit (1) aligned parameter;
dcl  code fixed bin(35);

	if tell_user &
	     ^ls_cp_info.no_io_switches &
	     ls_connection_desc_ptr ^= null
	then do;
	     on io_error go to IGNORE_IO_ERR;		/* Ignore errors due to disconnection. */
	     call ls_message_$print (ls_message_table_$hangup);
IGNORE_IO_ERR: revert io_error;
	end;

	if tell_initializer
	then call Send_disconnect_request ();

	call login_service_entries.disconnect (connection_name,
	     ls_connection_desc.connection_handle, ""b, code);

	if trace_switch
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0, "",
	     "Calling login_service_entries.disconnect for ^a.",
	     connection_name);

	if code ^= 0
	then call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
	     "login_server_entries.disconnect", DONT_TELL_USER,
	     DONT_TAKE_DUMP);

	call Remove_connection ();
	return;

     end Hangup_and_remove;
%page;
Remove_connection:
     procedure ();

/* clean up data bases associated with a now-perished connection */

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, 0, null (), 0, "",
		"Removing connection ^a at ^p.", connection_name, ls_connection_desc_ptr);

	if ls_connection_desc_ptr = null ()
	then return;				/* it's already done */

	if ls_connection_desc.connection_info_ptr ^= null ()
	then free ls_connection_desc.connection_info_ptr -> based_connection_info in (system_area);

	if ls_connection_desc.disconnect_event_channel ^= 0
	then call ipc_$delete_ev_chn (ls_connection_desc.disconnect_event_channel, (0));

	if ls_connection_desc.terminate_event_channel ^= 0
	then call ipc_$delete_ev_chn (ls_connection_desc.terminate_event_channel, (0));

	free ls_connection_desc in (system_area);

/* tell parent control point so it can reduce count of connections */

	call hcs_$wakeup (our_process_id, ls_cp_info.connection_gone_event_channel, 0, (0));

	free ls_cp_info in (system_area);

	if event_wait_list_ptr ^= null ()
	then free event_wait_list in (system_area);

	return;
     end Remove_connection;
%page;
Send_disconnect_request:
     procedure ();

/* subroutine to send "request" message to Initializer indicating that the connection has been broken */

dcl  1 auto_ls_reply_message aligned like ls_reply_message;

	if ls_process_info.initializer_handle = ""b
	then return;				/* Initializer doesn't know about this connection */

	ls_request_ptr = addr (auto_disconnect_request);
	ls_request_header.request_type = LS_DISCONNECT_REQUEST;
	ls_request_header.request_version = LS_DISCONNECT_REQUEST_VERSION_1;
	ls_request_header.header_version = LS_REQUEST_HEADER_VERSION_1;
	ls_request_header.reply_handle = ""b;
	ls_request_header.reply_event_channel = 0;	/* let send_ls_request_ make one */
	ls_request_header.pad1 = ""b;

	login_server_disconnect_request.handle = ls_process_info.initializer_handle;
	login_server_disconnect_request.process_id = ls_process_info.process_id;
	login_server_disconnect_request.connection_name = ls_connection_desc.name;

	ls_reply_message_ptr = addr (auto_ls_reply_message);

	call send_ls_request_ (ls_request_ptr, size (auto_disconnect_request), ls_reply_message_ptr, code);

	if code ^= 0
	then call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
	     "send_ls_request_", TELL_USER, TAKE_DUMP);

	else if ls_reply_message.code ^= 0
	then call ls_report_internal_error_ (code, OUR_NAME, ls_cp_info_ptr,
	     "0"b, "In reply to disconnect request.");

	return;

     end Send_disconnect_request;
%page;
%include as_user_message_add;
%page;
%include as_user_message_info;
%page;
%include condition_info;
dcl  1 ci aligned like condition_info;
%page;
%include condition_info_header;
%page;
%include cpm_entries;
%page;
%include dial_event_message;
%page;
%include dsa_log_constants;
%page;
%include event_wait_info;
%page;
%include event_wait_list;
%page;
%include login_server_messages;
%page;
%include login_service_entries;
%page;
%include ls_connection_desc;
%page;
%include ls_connection_message;
%page;
%include ls_cp_info;
%page;
%include ls_process_info;
%page;
%include ls_usage_types;
%page;
%include user_message_handles;

     end login_server_connection_;




		    login_server_overseer_.pl1      07/13/88  1248.3r w 07/13/88  0935.8      176598



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

/****^  HISTORY COMMENTS:
  1) change(85-03-01,Coren), approve(87-06-25,MCR7679), audit(87-02-26,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-02-26,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
      A) Changed a_initial_command to varying char string parm (dsa 153).
      B) Changed test entrypoint to allow caller to supply test info seg dir.
      C) Changed ls_ssu_info to be an internal static structure.  If quit is
         done without stopping all endpoints, entering login_server later in
         same process will still know about the ongoing endpoints. (dsa 104)
  3) change(87-05-08,GDixon), approve(87-06-25,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Use ssu_request_tables_$standard_requests rather than allowing a limited
     subset of standard requests in our own request table.
  4) change(87-06-25,GDixon), approve(87-06-25,MCR7679),
     audit(87-07-07,Parisek), install(87-08-04,MR12.1-1055):
     Add -probe control arg to $test entrypoint.
  5) change(87-07-06,GDixon), approve(87-07-06,MCR7679),
     audit(87-07-07,Parisek), install(87-08-04,MR12.1-1055):
      A) Correct problems in code which invokes start_up.ec when not in test
         mode.
      B) Set ssu_ to use exec_com search list to find login server ec's.
                                                   END HISTORY COMMENTS */

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

login_server_overseer_:
     procedure (a_pit_ptr, a_call_listen, a_initial_command);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This is the process overseer for a login server daemon.  Basically all it */
/* does is establish default handlers and set up an ssu_ invocation to       */
/* process requests.					       */
/*							       */
/* The "test" entry is used to run the login server code in test mode in an  */
/* interactive process.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  a_pit_ptr pointer parameter;
dcl  a_call_listen bit (1) parameter;
dcl  a_initial_command char (*) varying parameter;


/* AUTOMATIC */

dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp pointer;
dcl  argx fixed bin;
dcl  bc fixed bin (24);
dcl  call_probe_mode bit (1);
dcl  code fixed bin (35);
dcl  debug_mode bit (1);
dcl  entry_type fixed bin (2);
dcl  first_process bit (1);
dcl  info_dir_name char (168);
dcl  initial_command_line char (200);
dcl  login_server_info_dir char (168);
dcl  nargs fixed bin;
dcl  pathx fixed bin;
dcl  ready_to_listen bit (1);
dcl  sci_ptr pointer;
dcl  start_up_dir char (168);
dcl  system_dir_name char (168);

/* AUTOMATIC STRUCTURES */

dcl  1 logout_msg aligned,				/* for passing to terminate_process_ */
       2 version fixed bin,
       2 flags unaligned,
         3 hold bit (1),
         3 brief bit (1),
         3 mbz bit (34);

/* ENTRIES */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  com_err_ entry () options (variable);
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$rsnpnnl entry () options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  login_server_info_$test entry (char (*));
dcl  ls_cleanup_connections_ entry ();
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  probe entry options (variable);
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  ssu_$cpescape_disabled entry;
dcl  ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
dcl  ssu_$destroy_invocation entry (ptr);
dcl  ssu_$execute_start_up entry () options (variable);
dcl  ssu_$listen entry (ptr, ptr, fixed bin (35));
dcl  ssu_$print_message entry () options (variable);
dcl  ssu_$set_ec_search_list entry (ptr, char(32));
dcl  ssu_$set_ec_suffix entry (ptr, char (32));
dcl  ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  terminate_process_ entry (char (*), ptr);


/* EXTERNAL STATIC */

dcl  (
     error_table_$badopt,
     error_table_$noentry,
     error_table_$too_many_names
     ) fixed bin (35) external static;
dcl  iox_$error_output pointer external static;
dcl  iox_$user_input pointer external static;
dcl  ls_data_$connect_info_dir char (168) external static;
dcl  ls_data_$login_info_dir char (168) external static;
dcl  ls_data_$login_server_info_dir char (168) external static;
dcl  ls_ssu_request_tables_$overseer_requests fixed bin external static;
dcl  ssu_et_$subsystem_aborted fixed bin (35) external static;
dcl  ssu_request_tables_$standard_requests bit (36) aligned external static;
dcl  sys_info$system_control_dir char (168) varying external static;


/* INTERNAL STATIC */

dcl  ANSWER_TABLE_NAME char (32) internal static options (constant) initial ("answer_table");
dcl  EC_SEARCH_LIST char(32) int static options(constant) init("exec_com");
dcl  INSTALLATION_PARMS_NAME char (32) internal static options (constant) initial ("installation_parms");
dcl  LARGE_NUMBER fixed bin internal static options (constant) initial (100000);
						/* for adding standard request table at end */
dcl  LS_SS_EC_SUFFIX char (32) internal static options (constant) initial ("lsec");
dcl  LS_SS_NAME char (12) internal static options (constant) initial ("login_server");
dcl  NORMAL_MODE fixed bin internal static initial (1);	/* for condition_interpreter_ */
dcl  PROCESS_TYPE (0:3) character (12) varying internal static options (constant)
	initial (" initializer", " interactive", " absentee", " daemon");
dcl  PROG_NAME char (22) internal static options (constant) initial ("login_server_overseer_");
dcl  START_UP_DOT_EC char (11) internal static options (constant) initial ("start_up.ec");
dcl  TRACE_NAME char (18) internal static options (constant) initial ("login_server_trace");
dcl  UDD char (13) internal static options (constant) initial (">user_dir_dir");
dcl  trace_switch bit (1) internal static initial ("0"b);	/* can be changed by ls_trace command */


/* INTERNAL STATIC STRUCTURES */

dcl  1 static_ls_ssu_info aligned like ls_ssu_info internal static;


/* BUILTINS AND CONDITIONS */

dcl  (any_other, cleanup, quit) condition;

dcl  (addr, index, length, null, rtrim, string, substr) builtin;
%page;
	call_probe_mode = "0"b;
	debug_mode = "0"b;
	pit_ptr = a_pit_ptr;
	a_call_listen = "0"b;
	system_dir_name = sys_info$system_control_dir;
	login_server_info_dir = ls_data_$login_server_info_dir;
	ls_ssu_info_ptr = addr (static_ls_ssu_info);
	ls_ssu_info.flags = "0"b;
	ls_ssu_info.login_info_dir = ls_data_$login_info_dir;
	ls_ssu_info.connect_info_dir = ls_data_$connect_info_dir;

OVERSEER_JOIN:
	sci_ptr = null ();
	ready_to_listen = "0"b;
	on any_other call Any_other_handler ();
	on quit call Quit_handler ();

	if ^debug_mode
	then do;

/* Find and run the start_up exec_com. This code is lifted almost verbatim from process_overseer_ */

	     initial_command_line = "";

	     first_process = (pit_ptr -> pit.n_processes = 1);
						/* see if new_proc or login */

	     if ^pit_ptr -> pit.at.nostartup
	     then do;				/* start_up is allowed */

/* First try homedir */

		start_up_dir = pit_ptr -> pit.homedir;
		call hcs_$status_minf (start_up_dir, START_UP_DOT_EC, 1, entry_type, bc, code);

/* note that we assume any error is cause to look elsewhere to give best chance
   of success */

		if code = 0 & entry_type = 1
		then ;

/* now try projectdir */

		else do;
		     start_up_dir = UDD || ">" || pit_ptr -> pit.project;
		     call hcs_$status_minf (start_up_dir, START_UP_DOT_EC, 1, entry_type, bc, code);

		     if code = 0 & entry_type = 1
		     then ;
		     else do;
		          start_up_dir = sys_info$system_control_dir;
			call hcs_$status_minf (start_up_dir, START_UP_DOT_EC, 1, entry_type, bc,
			     code);
			if code = 0 & entry_type = 1
			then ;
			else goto NO_START_UP;
		     end;
		end;

		initial_command_line = "exec_com " || requote_string_ (pathname_ (start_up_dir, START_UP_DOT_EC));

		if first_process
		then initial_command_line = rtrim (initial_command_line) || " login ";
		else initial_command_line = rtrim (initial_command_line) || " new_proc ";

		initial_command_line = rtrim(initial_command_line) || PROCESS_TYPE (pit_ptr -> pit.process_type);

		call cu_$cp (addr (initial_command_line), length (initial_command_line), (0));
						/* code is uninteresting */
	     end;					/* the block that checked pit.nostart */
NO_START_UP:
	end;

	call ls_cleanup_connections_ ();		/* dispose of any connections belong to now-defunct servers */

/* Now we're ready to start the subsystem */

	ls_ssu_info.version = LS_SSU_INFO_V1;
	ls_ssu_info.debug_mode = debug_mode;
	ls_ssu_info.call_probe = call_probe_mode;
	ls_ssu_info.trace = trace_switch;
	if ls_ssu_info.n_endpoints = 0
	then ls_ssu_info.first_endpoint_ptr, ls_ssu_info.last_endpoint_ptr = null;

	ls_ssu_info.answer_table_ptr, ls_ssu_info.installation_parms_ptr = null ();
	on cleanup call Clean_up ();

	call initiate_file_ (system_dir_name, ANSWER_TABLE_NAME, R_ACCESS, ls_ssu_info.answer_table_ptr, (0), code);
	if code ^= 0
	then do;
	     call com_err_ (code, PROG_NAME, "Could not initiate answer table.");
	     go to EXIT;
	end;

	call initiate_file_ (system_dir_name, INSTALLATION_PARMS_NAME, R_ACCESS, ls_ssu_info.installation_parms_ptr,
	     (0), code);
	if code ^= 0
	then do;
	     call com_err_ (code, PROG_NAME, "Could not initiate installation_parms.");
	     go to EXIT;
	end;

	call ssu_$create_invocation (LS_SS_NAME, LS_SS_VERSION, ls_ssu_info_ptr,
	     addr (ls_ssu_request_tables_$overseer_requests), login_server_info_dir, sci_ptr, code);
	if code ^= 0
	then do;
	     call com_err_ (code, PROG_NAME, "Could not create subsystem invocation.");
	     go to EXIT;
	end;

	ls_ssu_info.sci_ptr = sci_ptr;

	if ^debug_mode
	then call ssu_$set_procedure (sci_ptr, "cpescape", ssu_$cpescape_disabled, code);
						/* no ".." escapes in login server environment, please */


	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not set ""cpescape"" procedure.");
	     go to WRAP_UP_AND_EXIT;
	end;

	call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), LARGE_NUMBER, code);
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Could not add standard request table.");
	     go to WRAP_UP_AND_EXIT;
	end;

          call ssu_$set_ec_search_list (sci_ptr, EC_SEARCH_LIST);
	call ssu_$set_ec_suffix (sci_ptr, LS_SS_EC_SUFFIX);
	call ssu_$execute_start_up (sci_ptr, code);
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Invoking start_up.^a", LS_SS_EC_SUFFIX);
	     if code ^= error_table_$noentry
	     then go to WRAP_UP_AND_EXIT;
	end;

	ready_to_listen = "1"b;
LISTEN:
	call ssu_$listen (sci_ptr, null (), code);
	if code ^= ssu_et_$subsystem_aborted
	then call ssu_$print_message (sci_ptr, code, "From ssu_$listen.");

WRAP_UP_AND_EXIT:
	call ssu_$destroy_invocation (sci_ptr);

EXIT:
	call Clean_up ();

	if ^debug_mode
	then do;
	     logout_msg.version = 0;
	     string (logout_msg.flags) = "0"b;
	     call terminate_process_ ("logout", addr (logout_msg));
	end;

	return;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Syntax: login_server_overseer_$test test_sc1_dir test_info_dir {-probe}   */
/*							       */
/* Arguments:						       */
/* test_sc1_dir						       */
/*    Directory containing test versions of answering service databases to   */
/*    be used by the login server.				       */
/* test_info_dir						       */
/*    Directory containing the three Login Server subsystem info	       */
/*    directories, which contain info segments describing the subsystem      */
/*    requests.  Three subdirectories must reside in test_info_dir:	       */
/*       login_server_info, login_info and login_connect_info	       */
/* -probe, -pb						       */
/*    when control points report an error, call probe after reporting the    */
/*    error to allow a chance for further debugging.  By default, execution  */
/*    continues within the control point after the error is reported.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


test:
     entry options (variable);

	call cu_$arg_count (nargs, code);
	if code ^= 0
	then do;
	     call com_err_ (code, PROG_NAME, "From cu_$arg_count.");
	     return;
	end;

	system_dir_name = sys_info$system_control_dir;
	login_server_info_dir = ls_data_$login_server_info_dir;
	ls_ssu_info_ptr = addr (static_ls_ssu_info);
	ls_ssu_info.flags = "0"b;
	ls_ssu_info.login_info_dir = ls_data_$login_info_dir;
	ls_ssu_info.connect_info_dir = ls_data_$connect_info_dir;
	call_probe_mode = "0"b;
	debug_mode = "1"b;

	pathx = 0;
	do argx = 1 to nargs;
	     call cu_$arg_ptr (argx, argp, argl, (0));
	     if index (arg, "-") = 1
	     then do;
		if arg = "-probe" | arg = "-pb"
		then call_probe_mode = "1"b;
		else if arg = "-no_probe" | arg = "-npb"
		then call_probe_mode = "0"b;
		else do;
		     call com_err_ (error_table_$badopt, PROG_NAME, arg);
		     return;
		end;
	     end;
	     else do;
		pathx = pathx + 1;
		if pathx = 1
		then do;
		     call absolute_pathname_ (arg, system_dir_name, code);
		     if code ^= 0
		     then do;
			call com_err_ (code, PROG_NAME, arg);
			return;
		     end;
		     call login_server_info_$test (system_dir_name);
		end;
		else if pathx = 2
		then do;
		     call absolute_pathname_ (arg, info_dir_name, code);
		     if code ^= 0
		     then do;
			call com_err_ (code, PROG_NAME, arg);
			return;
		     end;
		     login_server_info_dir = Test_dir_path (info_dir_name, ls_data_$login_server_info_dir);
		     ls_ssu_info.login_info_dir = Test_dir_path (info_dir_name, ls_data_$login_info_dir);
		     ls_ssu_info.connect_info_dir = Test_dir_path (info_dir_name, ls_data_$connect_info_dir);
		end;
		else do;
		     call com_err_ (error_table_$too_many_names, PROG_NAME, arg);
		     return;
		end;
	     end;
	end;

	go to OVERSEER_JOIN;
%page;
login_server_trace:
ls_trace:
     entry options (variable);

/* command to turn on and off tracing for the login server -- only affects
   subsequent calls to login_server_overseer_ */

	call cu_$arg_count (nargs, code);
	if code ^= 0
	then do;
	     call com_err_ (code, TRACE_NAME, "From cu_$arg_count.");
	     return;
	end;

	if nargs ^= 1
	then do;
	     call com_err_ (0, TRACE_NAME, "Usage: login_server_trace -on | -off");
	     return;
	end;

	call cu_$arg_ptr (1, argp, argl, (0));
	if arg = "-on"
	then trace_switch = "1"b;

	else if arg = "-off"
	then trace_switch = "0"b;

	else call com_err_ (error_table_$badopt, TRACE_NAME, arg);

	return;
%page;
Any_other_handler:
     procedure ();

dcl  cond_name char (32);

dcl  1 auto_condition_info aligned like condition_info;

	condition_info_ptr = addr (auto_condition_info);
	condition_info.version = condition_info_version_1;
	call find_condition_info_ (null (), condition_info_ptr, code);
	if code ^= 0
	then cond_name = "Unfindable";
	else cond_name = condition_info.condition_name;

	if cond_name = "Unfindable" | cond_name = "cput" | cond_name = "alrm"
						/* no point interpreting any of these */
	then call ioa_$ioa_switch (iox_$error_output, "login_server_overseer_: ^a condition.", cond_name);

	else if cond_name = "quit" | cond_name = "command_question" | cond_name = "command_error" | cond_name = "finish"
						/* pass these on */
	then do;
	     call continue_to_signal_ ((0));
	     return;
	end;

	else call condition_interpreter_ (null (), (null ()), (0), NORMAL_MODE, condition_info.mc_ptr, cond_name,
		condition_info.wc_ptr, condition_info.info_ptr);

	if debug_mode
	then call probe ();
	else go to WRAP_UP_AND_EXIT;

     end Any_other_handler;
%page;
Clean_up:
     procedure;

dcl  code fixed bin (35);

	if ls_ssu_info.answer_table_ptr ^= null ()
	then call terminate_file_ (ls_ssu_info.answer_table_ptr, 0, TERM_FILE_TERM, code);

	if ls_ssu_info.installation_parms_ptr ^= null ()
	then call terminate_file_ (ls_ssu_info.installation_parms_ptr, 0, TERM_FILE_TERM, code);

     end Clean_up;

%page;
Quit_handler:
     procedure ();

	if debug_mode
	then call continue_to_signal_ ((0));

	else do;
	     if ready_to_listen
	     then do;
		call ssu_$print_message (sci_ptr, 0, "QUIT signalled. Enter command:");
		go to LISTEN;
	     end;

/* if we hadn't finished setting up the subsystem, there's not a whole lot of choices */

	     else if /* tree */ Start_response ()
		then return;
		else if sci_ptr = null ()
		     then go to EXIT;
		     else go to WRAP_UP_AND_EXIT;
	end;
%page;
Start_response:
	procedure returns (bit (1));

/* "1"b if response is "start", "0"b if "logout" */

dcl  intro char (100) varying;
dcl  intro_len fixed bin;
dcl  code fixed bin (35);
dcl  buffer char (80);
dcl  chars_read fixed bin (21);
dcl  response char (80);

	     intro = "Early QUIT";

	     do while ("1"b);			/* exit conditions return */
		if sci_ptr = null ()
		then call ioa_$ioa_switch (iox_$error_output, "login_server_overseer_: ^a. logout or start?", intro);
		else call ssu_$print_message (sci_ptr, 0, "^a. logout or start?", intro);

		call iox_$get_line (iox_$user_input, addr (buffer), length (buffer), chars_read, code);
		if code ^= 0
		then do;				/* this is so bizarre, there's not point worrying about absence of subsystem */
		     if sci_ptr ^= null ()
		     then call ssu_$print_message (sci_ptr, code, "From iox_$get_line.");
		     return ("0"b);			/* punt */
		end;

		response = substr (buffer, 1, chars_read - 1);
						/* assume NL at the end */
		if response = "logout"
		then return ("0"b);
		else if response = "start"
		then return ("1"b);
		else call ioa_$rsnpnnl ("Invalid response: ""^a""", intro, intro_len, response);
	     end;					/* go read again */

	end Start_response;

     end Quit_handler;
%page;
Test_dir_path:
     procedure (test_dir, normal_dir) returns (char (168));

dcl  test_dir char (*);
dcl  normal_dir char (168);

dcl  code fixed bin (35);
dcl  ent_part char (32);

	call expand_pathname_ (normal_dir, "", ent_part, code);
	return (pathname_ (test_dir, ent_part));

     end Test_dir_path;
%page;
%include access_mode_values;
%page;
%include condition_info;
%page;
%include ls_ssu_info;
%page;
%include pit;
%page;
%include terminate_file;
%page;
%include user_attributes;

     end login_server_overseer_;




		    ls_cleanup_connections_.pl1     08/04/87  1514.8rew 08/04/87  1221.9       50418



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

/****^  HISTORY COMMENTS:
  1) change(85-08-01,Coren), approve(87-07-10,MCR7679), audit(87-03-18,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-18,GDixon), approve(87-07-10,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.
  3) change(87-05-28,GDixon), approve(87-07-10,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
      A) Remove orphan connections from active_connection_list which DSA does
         not know about.
      B) Remove orphan connections from active_connection_list which have no
         force_disconnect entry.
                                                   END HISTORY COMMENTS */

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

ls_cleanup_connections_:
     procedure ();

/* This routine is called during login_server initialization. Its job is to
   go through the active_connection_list and find any connections whose owner
   and user (if different) are both dead (i.e., invalid process IDs), and try
   to disconnect them.
*/

/* AUTOMATIC */

dcl  code fixed bin (35);
dcl  more bit (1);
dcl  offset bit (18);
dcl  owner_process_id bit (36) aligned;
dcl  user_process_id bit (36) aligned;
dcl  orphan bit (1);
dcl  force_disconnect_name char (64);

dcl  1 current_active_connection_info aligned like active_connection_info;

dcl  1 next_active_connection_info aligned like active_connection_info;


/* ENTRIES */

dcl  com_err_ entry () options (variable);
dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
dcl  hcs_$validate_processid entry (bit (36) aligned, fixed bin (35));
dcl  hpriv_connection_list_$delete_name entry (char (*) aligned, fixed bin (35));
dcl  hpriv_connection_list_$get_next entry (bit (18), ptr, fixed bin (35));

dcl  entry_to_call entry (char (*), fixed bin (35)) variable;


/* EXTERNAL STATIC */

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


/* INTERNAL STATIC */

dcl  PROG_NAME char (23) internal static options (constant) initial ("ls_cleanup_connections_");


/* BUILTINS & CONDITIONS */

dcl  (addr, null) builtin;
%page;
	next_active_connection_info.version = ACT_INFO_VERSION_1;

	more = Get_next (""b);
	do while (more);
	     offset = next_active_connection_info.offset;

	     owner_process_id = next_active_connection_info.owner_process_id;
	     call hcs_$validate_processid (owner_process_id, code);
	     if code ^= 0
	     then do;
		if code ^= error_table_$process_unknown
		then call com_err_ (code, PROG_NAME, "From hcs_$validate_processid.");

		user_process_id = next_active_connection_info.user_process_id;
		if user_process_id = ""b
		then orphan = "1"b;

		else if user_process_id = owner_process_id
		then orphan = "1"b;

		else do;
		     call hcs_$validate_processid (user_process_id, code);
		     orphan = (code ^= 0);
		     if code ^= 0 & code ^= error_table_$process_unknown
		     then call com_err_ (code, PROG_NAME, "From hcs_$validate_processid.");

		end;

		if orphan
		then current_active_connection_info = next_active_connection_info;
	     end;

	     else orphan = "0"b;

/* Have to get the next one before we process this one, because force_disconnect
   will probably result in current one's deletion */

	     more = Get_next (offset);

	     if orphan
	     then do;
		force_disconnect_name = current_active_connection_info.force_disconnect_entry;

		if force_disconnect_name ^= ""
		then do;

		     entry_to_call = cv_entry_ (force_disconnect_name, null (), code);
		     if code = 0
		     then call entry_to_call ((current_active_connection_info.connection_name), code);


		     if code ^= 0
		     then call com_err_ (code, PROG_NAME, "Force disconnecting ^a using ^a.",
			     current_active_connection_info.connection_name, force_disconnect_name);
		     if code = error_table_$io_no_permission
			& current_active_connection_info.network_service_type = "DSA"
		     then do;			/* DSA no longer recognizes session. */
			call hpriv_connection_list_$delete_name (current_active_connection_info.connection_name,
			     code);
			if code ^= 0
			then call com_err_ (code, PROG_NAME, "Deleting ^a from connection list.",
				current_active_connection_info.connection_name);
		     end;
		end;

		else do;
		     call com_err_ (0, PROG_NAME, "No force_disconnect entry for ^a.",
			current_active_connection_info.connection_name);
		     call hpriv_connection_list_$delete_name (current_active_connection_info.connection_name, code);
		     if code ^= 0
		     then call com_err_ (code, PROG_NAME, "Deleting ^a from connection list.",
			     current_active_connection_info.connection_name);
		end;
	     end;
	end;

EXIT:
	return;
%page;
Get_next:
     procedure (a_offset) returns (bit (1));

dcl  a_offset bit (18);

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

	offset = a_offset;
	call hpriv_connection_list_$get_next (offset, addr (next_active_connection_info), code);
	if code = error_table_$noentry
	then return ("0"b);

	else if code ^= 0
	then do;
	     call com_err_ (code, PROG_NAME, "Calling hpriv_connection_list_$get_next.");
	     go to EXIT;
	end;

	else return ("1"b);
     end Get_next;
%page;
%include active_connection_info;

     end ls_cleanup_connections_;




		    ls_convert_as_error_code_.pl1   08/04/87  1514.8rew 08/04/87  1221.9       28179



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

/****^  HISTORY COMMENTS:
  1) change(85-08-01,Coren), approve(87-07-10,MCR7679), audit(87-03-01,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-18,GDixon), approve(87-07-10,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.
                                                   END HISTORY COMMENTS */

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

ls_convert_as_error_code_:
     procedure (a_code) returns (fixed bin (35));

/* This function is used for error codes passed from the Initializer that come
   from as_error_table_, which is used for codes that are of interest only to
   the answering service and login servers. Because these codes were obtained
   from another process, the correct segment number must be patched in. This is
   unpleasant, but is considered less so than adding 50 or more special-purpose
   messages to error_table_.

   If the segment number matches that of system error codes, no conversion is
   done.

   Note that the segment number in this process for as_error_table_ is kept in
   internal static; a value of all zeroes means it hasn't been initialized yet, whereas
   all ones means we tried to get the segment number and failed.
*/

dcl  a_code fixed bin (35) parameter;

dcl  code fixed bin (35);
dcl  et_ptr pointer;
dcl  local_code fixed bin (35);

dcl  1 code_structure based aligned,			/* this is what an error code looks like */
       2 segno bit (18) unaligned,
       2 offset fixed bin (18) unsigned unaligned;

dcl  as_error_table_segno bit (18) internal static initial (""b);
						/* will be set to segment number of as_error_table_ the first time we need it */

dcl  AS_ERROR_TABLE_NAME char (15) internal static options (constant) initial ("as_error_table_");
dcl  SYS_ERROR_TABLE_SEGNO bit (18) internal static options (constant) initial ("077777"b3);


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

dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));

dcl  (addr, baseno, null) builtin;
%page;
	if a_code = 0
	then return (0);

	code = a_code;

	if addr (code) -> code_structure.segno = SYS_ERROR_TABLE_SEGNO
						/* it's from error_table_ anyway */
	then return (code);

	if as_error_table_segno = ""b
	then do;					/* we haven't got the segment number in this process yet */
	     call hcs_$make_ptr (null (), AS_ERROR_TABLE_NAME, "", et_ptr, local_code);
	     if local_code ^= 0			/* we can't */
	     then as_error_table_segno = "777777"b3;	/* tough */

	     else as_error_table_segno = baseno (et_ptr);
	end;

	if as_error_table_segno = "777777"b3
	then return (error_table_$no_message);		/* for lack of anything better */

	else do;
	     addr (code) -> code_structure.segno = as_error_table_segno;
	     return (code);
	end;

     end ls_convert_as_error_code_;




		    ls_data_.cds                    08/04/87  1517.0rew 08/04/87  1221.9       26703



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

/* HISTORY COMMENTS:
  1) change(86-08-01,Coren), approve(87-07-10,MCR7679), audit(87-02-27,GDixon),
     install(87-08-04,MR12.1-1055):
     Written.
  2) change(87-02-27,GDixon), approve(87-07-10,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Modified for move of login server from DSA software into the Multics
     Networking Architecture (MNA).  Info dir paths changed as a result.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */
ls_data_:
     procedure ();

/* This is the CDS source for creating ls_data_ */
%page;
/* AUTOMATIC */

dcl  code fixed bin (35);
dcl  1 cda like cds_args;

dcl  1 ls_data aligned,
       2 login_server_info_dir char (168),		/* info directory for requests for login server itself */
       2 login_info_dir char (168),			/* info directory for regular login requests */
       2 connect_info_dir char (168),			/* info directory for connect-loop requests */
       2 suffix (0:9) char (4),			/* ordinal suffixes for numbers not in the range 10:19 */
       2 teens_suffix (0:9) char (4);			/* ordinal suffixes for numbers in teens */


/* INTERNAL STATIC */

dcl  OUR_NAME char (8) internal static options (constant) initial ("ls_data_");


/* ENTRIES */

dcl  com_err_ entry () options (variable);
dcl  create_data_segment_ entry (ptr, fixed bin (35));


/* BUILTINS AND CONDITIONS */

dcl  (addr, null, size, string) builtin;
%page;

/* info directory names...may need to be changed for installation */

	ls_data.login_server_info_dir = ">doc>subsystem>login_server_info";
	ls_data.login_info_dir = ">doc>subsystem>login_info";
	ls_data.connect_info_dir = ">doc>subsystem>login_connect_info";

/* end info directory names */

	ls_data.teens_suffix (*) = "th  ";
	ls_data.suffix (*) = "th  ";
	ls_data.suffix (1) = "st  ";
	ls_data.suffix (2) = "nd  ";
	ls_data.suffix (3) = "rd  ";

/* structure is all set up, now create the data segment */

	cda.sections (1).p = addr (ls_data);
	cda.sections (1).len = size (ls_data);
	cda.sections (1).struct_name = "ls_data";
	cda.sections (2).p = null ();
	cda.sections (2).len = 0;
	cda.sections (2).struct_name = "";

	cda.seg_name = OUR_NAME;
	cda.num_exclude_names = 0;
	cda.exclude_array_ptr = null ();
	string (cda.switches) = ""b;
	cda.have_text = "1"b;

	call create_data_segment_ (addr (cda), code);
	if code ^= 0
	then call com_err_ (code, OUR_NAME, "From create_data_segment_.");

	return;
%page;
%include cds_args;

     end ls_data_;




		    ls_dump_.pl1                    10/28/88  1413.7r w 10/28/88  1302.2       95517



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

/****^  HISTORY COMMENTS:
  1) change(87-04-08,GDixon), approve(87-07-10,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
     Created from as_dump_.
  2) change(87-04-29,GDixon), approve(87-07-10,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
     Add dump_entryname parameter.
  3) change(87-05-06,GDixon), approve(87-07-10,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
     Add $report_error entrypoint to avoid calling ls_report_subr_error_ when
     it called us.
  4) change(87-05-14,GDixon), approve(87-07-10,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
     Ignore errors in submitting dprint of lsdump.
                                                   END HISTORY COMMENTS */

ls_dump_: proc (dumpid, a_ls_cp_info_ptr, dump_entryname);


/* PARAMETERS */

dcl	dumpid			char (*) varying parameter;
						/* caller msg    */
dcl	a_ls_cp_info_ptr		ptr;		/* connect. info */
dcl	dump_entryname		char(32);		/* ename (Out)   */
	

/* AUTOMATIC */

dcl	ABORT_LABEL		label,		/* escape route  */
	call_ls_report		bit(1),
	dir			char (168),	/* put dump here */
	doing_stack_trace		bit (1),
	code			fixed bin (35),
	iocbP			ptr,
	iqct			fixed bin,
	outname			char (32),
	quota			fixed bin(18),
	sp			ptr,
	stream			char(32),
	taccsw			fixed bin (1),
	time			fixed bin(71),
	trp			fixed bin (35),
	tup			bit (36) aligned,
	ucs_recursion		fixed bin,
	used			fixed bin;


/* INTERNAL STATIC */

dcl	ENOUGH			fixed bin int static init(64),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1)
				     int static options(constant),
	PROC			char(8) int static options(constant) init("ls_dump_");


/* EXTERNAL STATIC */

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


/* ENTRIES */

dcl	condition_		entry (char(*), entry);
dcl	cu_$arg_list_ptr		entry returns(ptr);
dcl	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21),
				     fixed bin(35));
dcl	cu_$stack_frame_ptr		entry (ptr);
dcl	date_time_$format		entry (char(*), fixed bin(71),
				     char(*), char(*))
				     returns(char(250) var);
dcl	dprint_			entry (char(*), char(*), ptr,
				     fixed bin(35));
dcl	hcs_$quota_get		entry (char(*), fixed bin(18),
				     fixed bin(35), bit(36) aligned,
				     fixed bin, fixed bin(1),
				     fixed bin, fixed bin(35));
dcl	ioa_$ioa_switch		entry() options(variable);
dcl	iox_$attach_name		entry (char(*), ptr, char(*), ptr,
				     fixed bin(35));
dcl	iox_$close		entry (ptr, fixed bin(35));
dcl	iox_$destroy_iocb		entry (ptr, fixed bin(35));
dcl	iox_$detach_iocb		entry (ptr, fixed bin(35));
dcl	iox_$open			entry (ptr, fixed bin, bit(1) aligned,
				     fixed bin(35));
dcl       ls_report_error_		entry (fixed bin(35), char(*), ptr,
				     bit(1) aligned, ptr, fixed bin,
				     fixed bin);
dcl	pathname_			entry (char(*), char(*))
				     returns(char(168));
dcl	trace_stack_$hregs		entry (ptr, fixed bin, fixed bin,
				     char(32) aligned, fixed bin);
dcl	user_info_$homedir		entry (char(*));


/* BUILTINS and CONDITIONS */

dcl       (addr, clock, null)
				builtin;
dcl	cleanup			condition;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


	call_ls_report = TRUE;
	go to JOIN;
	
report_error:
	entry (dumpid, a_ls_cp_info_ptr, dump_entryname);
	
	call_ls_report = FALSE;
	go to JOIN;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INITIALIZATION:						       */
/* 1) Access information describing the connection.		       */
/* 2) Establish a cleanup handler to close I/O switches if an error occurs.  */
/* 3) Establish an any_other handler to trap errors which occur while taking */
/*    the dump.  Recursive errors are fatal.			       */
/* 4) Get path of directory in which to place dumps.		       */
/* 5) Check to ensure there is enough quota in dump dir to hold another dump.*/
/* 6) Attach/open I/O switch on which dump will be written.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

JOIN:	ls_cp_info_ptr = a_ls_cp_info_ptr;
	ls_connection_desc_ptr = ls_cp_info.connection_desc_ptr;

	iocbP = null;
	on cleanup call Cleanup;

	doing_stack_trace = FALSE;
	ucs_recursion = 0;
	ABORT_LABEL = TRY_TO_CLEANUP;
	call condition_ ("any_other", Fatal_condition);	/* No recursion! */

	call user_info_$homedir (dir);

	call hcs_$quota_get (dir, quota, trp, tup, iqct, taccsw, used, code);
	call Abort (code, "Dump aborted, getting quota of dump dir^/(^a).",
	   dir);
	if quota ^= 0 then				/* Make sure there is room for the dump. */
	if (quota - used) < ENOUGH then 
	   call Abort (error_table_$rqover,
	      "Dump aborted, too little quota in dump dir^/(^a).", dir);

	time = clock();
	outname = date_time_$format ("lsdump.^yc^my^dm^Hd^MH." ||
	   ls_connection_desc.name, time, "system_zone", "system_lang");
	dump_entryname = outname;
	stream = "ls_dump_." || ls_connection_desc.name;

	call iox_$attach_name (stream, iocbP,
	   "vfile_ " || pathname_ (dir, outname) || " -extend",
	   null (), code);
	call Abort (code, "Dump aborted, could not attach lsdump^/(^a).",
	   pathname_ (dir, outname));
	call iox_$open (iocbP, Stream_output, ""b, code);
	call Abort (code, "Dump aborted, could not open lsdump^/(^a).",
	   pathname_ (dir, outname));

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* TRACE STACK:						       */
/* 1) Emit header for the dump.				       */
/* 2) Trace the stack.					       */
/* 3) Emit trailer for the dump.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call ioa_$ioa_switch (iocbP, "^a  ^a^2/",
	   date_time_$format ("^<iso_date_time> ^da", time,
	   "system_zone", "system_lang"), dumpid);

	call cu_$stack_frame_ptr (sp);
	doing_stack_trace = TRUE;
	call trace_stack_$hregs (sp, 2, -1, (stream), 1);
	doing_stack_trace = FALSE;

	call ioa_$ioa_switch (iocbP, "^/End of dump.^/");

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* EPILOGUE:						       */
/* 1) Close/detach lsdump I/O switches.				       */
/* 2) Make recursive conditions simply cause a return.		       */
/* 3) Dprint the lsdump.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

TRY_TO_CLEANUP:
	call Cleanup();

	ABORT_LABEL = JUST_RETURN;			/* any errors from now on will return and not try to cleanup */

	dpap = addr (dprint_arg_buf);			/* Set up to print segment. */
	dprint_arg.version = 1;
	dprint_arg.copies = 1;
	dprint_arg.delete = 0;
	dprint_arg.queue = 1;
	dprint_arg.pt_pch = 1;
	dprint_arg.notify = 0;
	dprint_arg.heading = " for lsdump " || dumpid;
	dprint_arg.output_module = 1;
	dprint_arg.dest = "SysAdmin";
	call dprint_ (dir, outname, dpap, code);	/* Request IO daemon to print the dump. */
						/* Ignore dprint errors, if any. */

	if call_ls_report then
	   call Abort (-1, "^a  Dprinted lsdump^/(^a).",
	   dumpid, pathname_(dir, outname));

JUST_RETURN:
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort:  Internal procedure to report errors in the Login_Server root      */
/*	 control point (on its message coordinator terminal and in its     */
/*	 log.						       */
/*							       */
/* Syntax:  call Abort (code, ioa_ctl_str, args);			       */
/*							       */
/* 1) Access code arg.  If 0 then return (no error, no Abort).	       */
/* 2) If code = -1, then set it to zero (no code msg) but continue	       */
/*    diagnosing an error.					       */
/* 3) Call ls_report_error_.					       */
/* 4) Go to ABORT_LABEL.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


Abort:	procedure options (variable);

dcl	ARGS_NO			fixed bin int static options(constant) init(3),
	IOA_CTL_STR_NO		fixed bin int static options(constant) init(2),
	TELL_USER			bit (1) aligned int static options(constant) init("1"b),
	codeP			ptr,
	code			fixed bin(35) based (codeP);

	call cu_$arg_ptr (1, codeP, 0, 0);
	if code = 0 then return;
	if code = -1 then code = 0;

	call ls_report_error_ (code, PROC, addr(ls_cp_info),
	   TELL_USER, cu_$arg_list_ptr(), IOA_CTL_STR_NO, ARGS_NO);

	go to ABORT_LABEL;

	end Abort;

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


Cleanup:	procedure;

dcl	code			fixed bin(35);

	if iocbP ^= null then do;
	   call iox_$close (iocbP, code);
	   call iox_$detach_iocb (iocbP, code);
	   call iox_$destroy_iocb (iocbP, code);
	   iocbP = null;
	   end;

	end Cleanup;

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


Fatal_condition:
	proc (mcptr, cname, coptr, infoptr, cont);

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

	if cname = "cleanup" then return;
	if cname = "storage" then go to CONTINUE_TO_SIGNAL;
	if cname = "command_error" then go to CONTINUE_TO_SIGNAL;
	if cname = "stack" then go to CONTINUE_TO_SIGNAL;
	if cname = "finish" then go to CONTINUE_TO_SIGNAL;
	if cname = "mme2" then go to CONTINUE_TO_SIGNAL;
	if cname = "cput" then go to CONTINUE_TO_SIGNAL;
	if cname = "alrm" then go to CONTINUE_TO_SIGNAL;
	if cname = "program_interrupt" then go to CONTINUE_TO_SIGNAL;
	if cname = "signal_io_" then go to CONTINUE_TO_SIGNAL;
	if cname = "quit" then do;
CONTINUE_TO_SIGNAL:
	   cont = TRUE;
	   return;
	   end;

	ucs_recursion = ucs_recursion + 1;		/* error occurred*/
	if ucs_recursion = 1 then do;			/* while dumping */
	   call Abort (-1,
	      "Dump aborted, condition ^a occurred is lsdump^/(^a).",
	      pathname_ (dir, outname));
	   end;

	ls_cp_info.no_io_switches = TRUE;
	go to JUST_RETURN;				/* error while   */
						/* aborting      */

	end Fatal_condition;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 %include dprint_arg;
 %include iox_modes;
 %include ls_connection_desc;
 %include ls_cp_info;

 	end ls_dump_;




		    ls_message_.pl1                 08/04/87  1514.8rew 08/04/87  1221.9       42930



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

/****^  HISTORY COMMENTS:
  1) change(85-08-01,Coren), approve(87-07-10,MCR7679), audit(07-02-27,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-18,GDixon), approve(87-07-10,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.
                                                   END HISTORY COMMENTS */

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

ls_message_:
     procedure ();

/* This procedure contains utility entrypoints for printing messages in a login server.
*/

/* AUTOMATIC */

dcl  arg_list_ptr pointer;
dcl  arg_count fixed bin;
dcl  argl fixed bin (21);
dcl  argp pointer;
dcl  code fixed bin (35);
dcl  nnl_switch bit (1) aligned;
dcl  output_message char (512);
dcl  output_message_len fixed bin (21);
dcl  error_message char (100) aligned;

dcl  message_locator_ptr pointer;
dcl  message_ptr pointer;


/* BASED */

dcl  fixed_bin_35_based fixed bin (35) based;

dcl  1 message_locator aligned based (message_locator_ptr),
       2 segno bit (18) unaligned,
       2 offset bit (18) unaligned;

dcl  1 message aligned based (message_ptr),
       2 length fixed bin (9) unsigned unaligned,
       2 string char (message_length refer (message.length)) unaligned;


/* ENTRIES */

dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  ioa_ entry () options (variable);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$general_rs_control_string
	entry (ptr, char (*), fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$nnl entry () options (variable);


/* BUILTINS AND CONDITIONS */

dcl  (baseptr, ptr) builtin;

dcl  io_error condition;
%page;
print:
     entry () options (variable);

/* This entry is called to print messages derived from ls_message_table_. The
   actual calling sequence is:

   call ls_message_$print (message_locator, ioa_args...);

   where message_locator is an error-code-like object (see the declaration of
   message_locator, above) which is used to find an ACC string (see the declaration
   of message) which is actually an ioa_ control string.
*/

	nnl_switch = "0"b;
	go to PRINT_JOIN;

print_nnl:
     entry () options (variable);

/* same as print but suppresses the trailing newline */

	nnl_switch = "1"b;

PRINT_JOIN:
	call cu_$arg_list_ptr (arg_list_ptr);
	call cu_$arg_count (arg_count, (0));

	call cu_$arg_ptr (1, message_locator_ptr, argl, code);
	if code ^= 0
	then signal io_error;			/* this would be pretty outrageous */

	message_ptr = ptr (baseptr (message_locator.segno), message_locator.offset);

	if arg_count = 1				/* no data args, just print the string */
	then if nnl_switch
	     then call ioa_$nnl (message.string);
	     else call ioa_ (message.string);

	else do;					/* send ioa_ the control string and let it apply the data args */
	     call ioa_$general_rs_control_string (arg_list_ptr, message.string, 2, output_message, output_message_len,
		"0"b, "0"b);

	     begin;

dcl  actual_output_message char (output_message_len) defined (output_message);

		if nnl_switch
		then call ioa_$nnl ("^a", actual_output_message);
		else call ioa_ ("^a", actual_output_message);
	     end;

	end;

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

/* this entry is used to print error messages, with an error code supplied.
   The calling sequence is:

   call ls_message_$print_error (code, ioa_control_string, ioa_args...);

   where the ioa_control_string and ioa_args are optional.
*/

	call cu_$arg_count (arg_count, (0));

	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0
	then signal io_error;			/* unlikely to have been called with no arguments */

	call convert_status_code_ (argp -> fixed_bin_35_based, (""), error_message);

	if arg_count > 1
	then do;
	     call cu_$arg_list_ptr (arg_list_ptr);
	     call ioa_$general_rs (arg_list_ptr, 2, 3, output_message, output_message_len, "0"b, "0"b);
	end;

	else do;
	     output_message = "";
	     output_message_len = 0;
	end;

	begin;

dcl  actual_output_message char (output_message_len) defined (output_message);

	     call ioa_ ("^[^a ^;^s^]^a", (error_message ^= ""), error_message, actual_output_message);

	end;

	return;

     end ls_message_;




		    ls_message_table_.alm           08/04/87  1516.0rew 08/04/87  1221.9       83592



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(85-03-01,Coren), approve(87-07-06,MCR7679),
"     audit(87-02-27,GDixon), install(87-08-04,MR12.1-1055):
"     Created out of as_error_table_.
"  2) change(87-04-02,GDixon), approve(87-07-06,MCR7679),
"     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
"      A) Add login_timeout message diagnosing login failure due to realtime
"         limit expiration (installation_parms.login_time).
"      B) Add bad_password_check message diagnosing error from check_password_.
"      C) Add new_password_indistinct message, diagnosing new password which
"               scrambles to same value as original password.
"  3) change(87-05-17,GDixon), approve(87-07-06,MCR7679),
"     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
"      A) Update list_process.
"      B) Add list_proc_he, the header for the table of disconnected
"               processes.
"                                                      END HISTORY COMMENTS

"  ls_message_table_ -- contains messages and control strings used by login
"  servers.

"  This table is not strictly speaking an error table: the messages are
"  generated by the ls_message macro, and do not contain short messages.

"  This module is installation replaceable.
"  It contains the text for error and informative messages typed by login
"  servers on user's terminals. Each installation may tailor these messages,
"  inserting phone numbers or whatever, or translating them into other
"  languages, as necessary.
"  One important motivation for having this table is so that installations
"  may be as informative or non-informative as they please about the
"  reasons for refusing login, depending on local security requirements.

"  Some of the items in this table are actually control strings for ioa_$rs.
"  Those which contain conditionals (i.e., ^[...^] constructs) or for
"  which the meaning of the data items is not immediately obvious are
"  accompanied by explanatory comments.

	include	et_macros
	
	include	ls_macros

	et	ls_message_table_

	ls_message aclass_banner_msg,(Channel access class: ^a.)
	ls_message already_logged_in,(^a.^a already logged in from ^a terminal ""^a"".)
	ls_message authorization,(******^/Your authorization is ^a.^/******)
	ls_message automatic_logout,(Automatic logout.)
	ls_message bad_login_arguments_string,(login: Error processing arguments following -arguments.)
	ls_message bad_login_word_msg,(Incorrect login word ""^a"".)
	ls_message bad_password_check,(login: Invalid password.  ^a.)
		" ^a is error message from check_password_ subroutine.
	ls_message bad_password_format,(login: Passwords must be 8 or less printing characters, without spaces or semi-colons)
	ls_message coming_up,(Multics is coming up. Try again in a few minutes.)
	ls_message connect_requests,(Please type list, create, connect, new_proc, destroy, logout, or help.)
	ls_message connected,(Your disconnected process^[ #^d^] will be connected to this terminal.)
"			number printed if there's more than 1
	ls_message connected_after_new_proc,(Your disconnected process^[ #^d^] will be connected to this terminal after new_proc.)
"			number printed if there's more than 1
	ls_message cost_message,(CPU usage^[ ^d min^;^s^] ^d sec, cost $^.2f.)
"			Condition is CPU usage >= 1 minute
	ls_message current_modes,(Current modes: ^a)
	ls_message current_terminal_id,(Current terminal ID is ""^a"".)
	ls_message current_terminal_type,(Current terminal type is ""^a"".)
	ls_message default_auth_changed,(Default authorization changed.)
	ls_message default_project_changed,(Default project changed.)
	ls_message dial_connect_msg,( ^a terminal ""^a"" dialed to ^a at ^a.)
	ls_message dial_logout,(Master process logged out.)
	ls_message dial_terminated,(Master process terminated. Please reissue dial command.)
	ls_message dialed_to_mc,(Channel ^a dialed to message coordinator.)
"			connection name
	ls_message disconnected_processes,(You have ^d disconnected process^[es^].)
"			condition is n_processes > 1
	ls_message dropped_by_mc,(^a dropped by message coordinator.)
"			connection name
	ls_message fatal_error,(Fatal error. Process has terminated. ^a)
"			^a is expansion of process-termination error code
	ls_message fpe_caused_logout,(Process has terminated and requested user logout.)
	ls_message fpe_during_init,(Fatal error during process initialization.)
	ls_message fpe_loop,(You appear to be in a fatal process error loop.)
	ls_message fpe_new_proc,(New process created.)
	ls_message generated_password,(Your new password is ""^a"", pronounced ""^a"".)
	ls_message generated_password_error,(New password typed incorrectly.)
	ls_message give_instructions,(Please give instructions regarding your disconnected process(es).)
	ls_message greeting_msg,(Multics ^a: ^a (Channel ^a)^/Load = ^.1f out of ^.1f units: users = ^d, ^a)
"			system_id, installation_id,...date_time
	ls_message hangup,(hangup^/)
	ls_message help_gpw_verify,(Verify your generated password before changing it, or enter ""quit"" to not log in.)
	ls_message help_new_password,(Enter your new password, or enter ""quit"" to not log in.)
	ls_message help_npw_verify,(Verify your new password before changing it, or enter ""quit"" to not log in.)
	ls_message help_password,(You must enter your password, or ""quit"" to not log in.)
	ls_message illegal_new_proc,(You cannot ""new_proc"" to the requested authorization.)
	ls_message incorrect_passwords,(Your password was given incorrectly ^[^d times recently.^/Last bad password ^;^s^]at ^a from ^a terminal ""^a"".)
"			condition is n_incorrect_passwords > 1
	ls_message last_login,(Last login ^a from ^a terminal ""^a"".)
	ls_message list_proc_header,(^2x^vtLOGIN TIME^vtCHANNEL^vtTERM TYPE^vtID^vt^[AUTH^])
	ls_message list_process,(^2d.^vt^a^vt^a^vt^a^vt^a^vt^[ring ^d^;^s^a^;ring ^d, ^a^])
	ls_message login,(^[Anonymous user ^]^a.^a logged in ^a from ^a terminal ""^a"".)
	ls_message login_args,(Personid.Projectid and optional arguments:)
	ls_message login_excess_wakeups,(High rate of wakeups indicates communication line failure.)
	ls_message login_requests,(Please type create, logout, or help.)
	ls_message login_timeout,(Login was not completed within ^.1f minute^[s^].)
	ls_message logout_disconnected,(^a.^a logged out ^a,^/while disconnected. No process affected by this logout.)
	ls_message logout,(^a.^a logged out ^a^/CPU usage^[ ^d min^;^s^] ^d sec, cost $^.2f.)
"			Condition is CPU usage >= 1 minute
	ls_message multiple_login_msg,(This is your ^d^a interactive login instance.)
"			^a represents suffix (-st, -nd, -th...)
	ls_message must_give_process_no,(You must specify the process number since you have more than one disconnected process.)
	ls_message need_authorization_for_cda,(login: -change_default_auth requires that -authorization also be used.)
	ls_message need_project_for_cdp,(login: syntax is ""login Person.NewDefaultProj -change_default_project."")
	ls_message new_password,(New Password:)
	ls_message new_password_again,(New Password Again:)
	ls_message new_password_error,(New password typed incorrectly second time.)
	ls_message new_password_indistinct,(The new password is equivalent to the old password.)
	ls_message no_connect_aclass,(Your disconnected process^[ #^d^] is not accessible from a terminal channel of this access class.)
"			^d = process number, only included if there is more than one
	ls_message no_disconnected_processes,(You have no disconnected processes.)
	ls_message no_line_permission,(You do not have permission to use this channel.)
	ls_message no_name,(Expected argument missing. User name not supplied.)
	ls_message no_such_process,(You don't have a disconnected process number ^d.)
	ls_message offer_help,(Please contact programming staff if you need assistance in correcting this problem.)
	ls_message password,(Password:)
	ls_message password_changed,(Password changed.)
	ls_message password_expired,(Your password has expired.  It must be changed once every ^d days.)
	ls_message password_format_warning,(Some of the characters entered as a password were ignored.)
	ls_message password_quit,(Login stopped by ""quit"".)
	ls_message password_unused_too_long,(Your password has not been used in more than ^d days.^/     It has automatically expired.)
	ls_message please_try_again,(Please try to log in again or type ""help"" for instructions.)
	ls_message process_destroyed,(Your disconnected process^[ #^d^;^] has been destroyed.)
"			number printed if there's more than 1
	ls_message protected,(You are protected from preemption^[ until ^a^].)
	ls_message requesting_dial_to_mc,(Requesting connection to message coordinator.)
	ls_message rq_invalid_now,(The ""^a"" request is not valid at this time.)
	ls_message shutdown,(Multics is shutting down.)
	ls_message special_session,(Special session in progress.)
	ls_message unknown_request,(Unknown request ""^a"".)
	ls_message user_required_for_dial,(You must use the control argument -user Person.Project for this channel.)
	end




		    ls_report_subr_error_.pl1       08/04/87  1514.7rew 08/04/87  1221.9       85482



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

/****^  HISTORY COMMENTS:
  1) change(85-08-01,Coren), approve(87-06-26,MCR7679), audit(87-02-27,GDixon),
     install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-03-03,GDixon), approve(87-06-26,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
      A) Add a pnotice, sort declarations.
      B) Add ls_report_error_ entrypoint.
  3) change(87-05-06,GDixon), approve(87-06-26,MCR7679),
     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
     Avoid recursion when ls_dump_ calls us, after we have called it.
  4) change(87-05-26,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
      A) Add take_dump parameter to ls_report_subr_error_ to restrict the
         kinds of failures that cause dumps.
  5) change(87-06-26,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-02,Parisek), install(87-08-04,MR12.1-1055):
      A) Don't report existence of lsdump when none was taken.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */
ls_report_subr_error_:
     procedure (a_code, a_caller_name, a_cp_info_ptr, a_subr_name,
        a_tell_user, a_take_dump);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/*							       */
/* This subroutine, and its entrypoint ls_report_internal_error_, cause      */
/* messages to be written on the parent control point's error output switch  */
/* (thereby either alerting an operator or writing in an MC log, or both).   */
/* If the "tell_user" switch is on, they also write a message on the	       */
/* connection.						       */
/*							       */
/* Since the current control point can't get at the parent's I/O switches, a */
/* wakeup is sent to a handler in the parent control point, using the	       */
/* ls_error_info structure.  In order to avoid taking the current control    */
/* point and its attendent information out from under the handler, this      */
/* procedure blocks until the handler sends a wakeup over the	       */
/* reply_event_channel to let us know that it's finished.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* PARAMETERS */

dcl  a_code fixed bin (35) parameter;
dcl  a_caller_name char (*) parameter;
dcl  a_cp_info_ptr pointer parameter;
dcl  a_subr_name char (*) parameter;
dcl  a_tell_user bit (1) aligned parameter;
dcl  a_take_dump bit (1) aligned parameter;
dcl  a_arg_list_ptr pointer parameter;
dcl  a_ioa_ctl_str_no fixed bin parameter;
dcl  a_ioa_args_no fixed bin parameter;


/* AUTOMATIC */

dcl  arg_list_ptr pointer;
dcl  argl fixed bin (21);
dcl  argp pointer;
dcl  caller_message char (256);
dcl  caller_message_len fixed bin (21);
dcl  caller_message_val char (caller_message_len) based (addr (caller_message));
dcl  caller_name char (32);
dcl  code fixed bin (35);
dcl  dump_entryname char (32);
dcl  error_message char (256) varying;
dcl  event_message fixed bin (71);
dcl  ipc_code fixed bin (35);
dcl  long_message char (100) aligned;
dcl  subr_name char (64);
dcl  take_ls_dump bit (1) aligned;
dcl  tell_user bit (1) aligned;


/* AUTOMATIC STRUCTURES */

dcl  1 auto_event_wait_info aligned like event_wait_info;


/* BASED */

dcl  arg char (argl) based (argp);
dcl  based_bit1 bit (1) based;
dcl  based_fb35 fixed bin (35) based;
dcl  based_ptr pointer based;


/* ENTRIES */

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_list_ptr 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  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ls_dump_$report_error entry (char (*) var, ptr, char (32));
dcl  ls_message_$print_error entry options (variable);

/* CONSTANTS */

dcl  NL char (1) int static options (constant) init ("
");

/* BUILTINS */

dcl  (addr, length, rtrim, unspec) builtin;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ls_report_subr_error_:					       */
/*   This entrypoint reports errors in supporting subroutines called by the  */
/*   login server.  It takes a fixed number of arguments, one of which is    */
/*   the name of the subroutine which returned the error.		       */
/*							       */
/* Syntax:  call ls_report_subr_error_ (code, caller, ls_cp_info_ptr,	       */
/*	       subroutine_name, tell_user, take_dump);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	take_ls_dump = a_take_dump;
	code = a_code;
	caller_name = a_caller_name;
	ls_cp_info_ptr = a_cp_info_ptr;
	subr_name = a_subr_name;
	tell_user = a_tell_user;

	call convert_status_code_ (code, (""), long_message);
	error_message = rtrim (long_message);
	error_message = error_message || " from ";
	error_message = error_message || subr_name;
	go to REPORT_JOIN;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ls_report_internal_error_:					       */
/*   This entrypoint reports errors detected by the login server programs    */
/*   themselves.						       */
/*							       */
/* Syntax:  call ls_report_internal_error_ (code, caller, ls_cp_info_ptr,    */
/*	       tell_user, ioa_ctl_string, ioa_args...);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

ls_report_internal_error_:
     entry options (variable);

	take_ls_dump = "1"b;
	call cu_$arg_ptr (1, argp, argl, (0));
	code = argp -> based_fb35;

	call cu_$arg_ptr (2, argp, argl, (0));
	caller_name = arg;

	call cu_$arg_ptr (3, argp, argl, (0));
	ls_cp_info_ptr = argp -> based_ptr;

	call cu_$arg_ptr (4, argp, argl, (0));
	tell_user = argp -> based_bit1;

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

	call cu_$arg_list_ptr (arg_list_ptr);
	call ioa_$general_rs (arg_list_ptr, 5, 6, caller_message, caller_message_len, "0"b, "0"b);

	error_message = rtrim (long_message);
	error_message = error_message || " ";
	error_message = error_message || caller_message_val;
	go to REPORT_JOIN;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ls_report_error_:					       */
/*   This entrypoint reports errors detected by the login server programs    */
/*   themselves, and reported via an internal procedure of the caller.       */
/*   Since the caller's internal error procedure takes a variable number of  */
/*   arguments, it passes us a pointer to its argument list so we can	       */
/*   extract the ioa_ctl_str and ioa_args from that arg list.	       */
/*							       */
/* Syntax:  call ls_report_internal_error_ (code, caller, ls_cp_info_ptr,    */
/*	       tell_user, arg_list_ptr, ioa_ctl_string_no, ioa_args_no...); */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

ls_report_error_:
     entry (a_code, a_caller_name, a_cp_info_ptr, a_tell_user, a_arg_list_ptr, a_ioa_ctl_str_no, a_ioa_args_no);

	take_ls_dump = "1"b;
	code = a_code;
	caller_name = a_caller_name;
	ls_cp_info_ptr = a_cp_info_ptr;
	tell_user = a_tell_user;
	arg_list_ptr = a_arg_list_ptr;

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

	call ioa_$general_rs (arg_list_ptr, a_ioa_ctl_str_no, a_ioa_args_no, caller_message, caller_message_len, "0"b,
	     "0"b);

	error_message = rtrim (long_message);
	error_message = error_message || " ";
	error_message = error_message || caller_message_val;
	go to REPORT_JOIN;

REPORT_JOIN:
	if tell_user
	then call ls_message_$print_error (code, "Internal error.");

	if take_ls_dump
	then do;
	     call ls_dump_$report_error (rtrim (caller_name) || ": " || error_message, ls_cp_info_ptr, dump_entryname);
	     error_message = error_message || NL;
	     error_message = error_message || "See lsdump:  ";
	     error_message = error_message || rtrim (dump_entryname);
	end;

	ls_error_info_ptr = ls_cp_info.error_info_ptr;
	ls_error_info.caller_name = caller_name;
	ls_error_info.error_message_length = length (error_message);
	ls_error_info.error_message = error_message;

	unspec (event_message) = unspec (ls_cp_info_ptr);
	call hcs_$wakeup ((get_process_id_ ()), ls_cp_info.error_event_channel, event_message, ipc_code);

	if ipc_code = 0
	then do;					/* wait for error handler to run so as not to destroy control point out from under it */
	     event_wait_channel.channel_id (1) = ls_error_info.reply_event_channel;
	     call ipc_$block (addr (event_wait_channel), addr (auto_event_wait_info), ipc_code);
	end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

%include ls_cp_info;

%include ls_error_info;

%include event_wait_channel;

%include event_wait_info;

     end ls_report_subr_error_;




		    ls_ssu_request_tables_.alm      08/04/87  1516.0rew 08/04/87  1221.9       71406



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" ***********************************************************

"Request tables for use by login servers.

" HISTORY COMMENTS:
"  1) change(85-03-01,Coren), approve(87-07-06,MCR7679),
"     audit(87-03-01,GDixon), install(87-08-04,MR12.1-1055):
"     Written.
"  2) change(87-03-04,GDixon), approve(87-07-06,MCR7679),
"     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
"      A) Add slave request, which lets the user know the slave request is not
"         supported by the Login Server.
"      B) Change help request to call ls_validate_user_$help, which prints
"         information about the subsystem when the help request is invoked
"         without arguments.
"      C) Sort ancillary requests (eg, access_mode, echo, temrinal_type, etc)
"         alphabetically following the more important requests of each table.
"      D) Standarize list_request descriptions for all requests.
"      E) Add the list_endpoints requests to the overseer_requests table.
"      F) Add the exec_com request to the overseer_requests table.
"  3) change(87-05-08,GDixon), approve(87-07-06,MCR7679),
"     audit(87-05-19,Parisek), install(87-08-04,MR12.1-1055):
"      A) Add all standard requests except abbrev, debug_mode, and execute to
"         the overseer_requests table.
"      B) Also, add the Multics pause and user commands to the
"               overseer_requests table.
"      C) Add a new endpoints_listening (epl) request to the overseer_requests
"               table.
"      D) Remove ready, ready_on and ready_off from the
"         enabled_standard_requests table, since this table is now used only
"         for the login and connect loop subsystems which do not want these
"         requests.
"  4) change(87-06-08,GDixon), approve(87-07-06,MCR7679),
"     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
"      A) Correct coding error in use of multics_request macro.
"  5) change(87-06-24,GDixon), approve(87-07-06,MCR7679),
"     audit(87-07-06,Parisek), install(87-08-04,MR12.1-1055):
"      A) In the login_requests table, add logout as a synonym for the hangup
"         command. But don't list or summarize logout since it is not one of
"         the documented commands at login time.  It is only documented for
"         use within the connect loop. (dsa 242)
"                                                      END HISTORY COMMENTS

	include	ssu_request_macros

	name	ls_ssu_request_tables_

"
"overseer_requests table -- used by login server process overseer. Just
"(start stop)_login_service and disable some of the standard requests.

	begin_table overseer_requests

	request	start_login_service,login_server_$start_service,(),
		(Start listening for connections.)

	request	stop_login_service,login_server_$stop_service,(),
		(Stop listening for connections.)

	request	endpoints_listening,login_server_$endpoints_listening,(epl),
		(Return status of listening on endpoints.),
		(flags.allow_both)

	request	list_endpoints,login_server_$list_endpoints,(lsep),
		(List endpoints listening for connections.)

	request	quit,login_server_$quit,(q),
		(Exit the login server subsystem.)

  multics_request   pause,(),
		(Pause for a given number of seconds.),,
		(flags.allow_command)

  multics_request   user,(),
		(Return or print attributes of the user process.),,
		(flags.allow_both)

  unknown_request   abbrev,(ab)
  unknown_request   debug_mode
  unknown_request	execute,(e)

	end_table overseer_requests

"
"login_requests table -- defines those requests that can be entered in response
"to a login banner

	begin_table login_requests

	request	login,ls_validate_user_$login,(l),
		(Login and establish a process.)

	request	enter,ls_validate_user_$enter,(e),
		(Login an anonymous user.)

	request	enterp,ls_validate_user_$enterp,(ep),
		(Login an anonymous user with a password.)

	request	dial,ls_validate_user_$dial,(d),
		(Connect to a dial server.)

	request	slave,ls_validate_user_$slave,(),
		(Change from login to slave service for duration of connection.),
		flags.allow_command+flags.dont_summarize+flags.dont_list

	request	access_class,ls_validate_user_$access_class,(acc),
		(Print the access class of the terminal connection.)

	request	echo,ls_validate_user_$echo,(),
		(Echo typed characters back to the terminal.)

	request	hangup,ls_validate_user_$hangup,(),
		(Terminate the login dialogue, hangup the terminal.)

	request	hello,ls_validate_user_$hello,(),
		(Print login banner.)

	request	logout,ls_validate_user_$hangup,(),
		(Terminate the login dialogue, hangup the terminal.),
		flags.allow_command+flags.dont_summarize+flags.dont_list

	request	modes,ls_validate_user_$modes,(),
		(Set or print the terminal modes.)

	request	noecho,ls_validate_user_$noecho,(),
		(Do not echo typed characters back to the terminal.)

	request	terminal_id,ls_validate_user_$terminal_id,(tid),
		(Set or print the terminal ID.)

	request	terminal_type,ls_validate_user_$terminal_type,(ttp),
		(Set or print the terminal type.)

	end_table login_requests
"
"connect_requests table -- defines those requests that may be entered in the
"'connect loop' after a user has been validated but before he has a process.

	begin_table connect_requests

	request	connect,ls_validate_user_$connect,(),
		(Connect to an existing disconnected process.)

	request	create,ls_validate_user_$create,(cr),
		(Create a new process.)

	request	destroy,ls_validate_user_$destroy,(),
		(Destroy an existing disconnected process.)

	request	hangup,ls_validate_user_$hangup,(),
		(Terminate the connect dialogue, disconnect the terminal.)

	request	list,ls_validate_user_$list,(ls),
		(List the user's disconnected processes.)

	request	logout,ls_validate_user_$logout,(),
		(Terminate the connect dialogue.)

	request	new_proc,ls_validate_user_$new_proc,(),
		(Replace an existing disconnected process with a new process.)

	request	access_class,ls_validate_user_$access_class,(acc),
		(Print the access class of the terminal connection.)

	request	echo,ls_validate_user_$echo,(),
		(Echo typed characters back to the terminal.)

	request	hello,ls_validate_user_$hello,(),
		(Print login banner.)

	request	modes,ls_validate_user_$modes,(),
		(Set or print the terminal modes.)

	request	noecho,ls_validate_user_$noecho,(),
		(Do not echo typed characters back to the terminal.)

	request	terminal_id,ls_validate_user_$terminal_id,(tid),
		(Set or print the terminal ID.)

	request	terminal_type,ls_validate_user_$terminal_type,(ttp),
		(Set or print the terminal type.)

	end_table connect_requests
"
" enabled_standard_requests table -- 
"  contains those "standard" ssu_requests that are allowed during the login
"  and connect dialogues.  The login_server_overseer_ request environment uses
"  ssu_request_tables_$standard_requests instead.

	begin_table enabled_standard_requests

	request	.,ssu_requests_$self_identify,(),
		(Identify the subsystem.)

	request	help,ls_validate_user_$help,(),
		(Obtain detailed information about the subsystem.)

	request	list_help,ssu_requests_$list_help,(lh),
		(List topics for which help is available.)

	request	list_requests,ssu_requests_$list_requests,(lr),
		(Briefly describe each subsystem request.)

	request	?,ssu_requests_$summarize_requests,(),
		(List names of subsystem requests.),
		flags.allow_command+flags.dont_summarize

	request	subsystem_name,ssu_requests_$subsystem_name,(),
		(Return the name of this subsystem.),
		flags.allow_both+flags.dont_summarize+flags.dont_list

	request	subsystem_version,ssu_requests_$subsystem_version,(),
		(Return the version number of this subsystem.),
		flags.allow_both+flags.dont_summarize+flags.dont_list

	end_table enabled_standard_requests

	end




		    ls_validate_user_.pl1           08/04/87  1514.7rew 08/04/87  1222.3     1127583



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

/****^  HISTORY COMMENTS:
  1) change(85-08-01,Coren), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-02-20,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Modified to properly set terminal type, based upon answerback
         term_type information returned by tty_info_$decode_answerback.
      B) Eliminate extra newline following special session line of greeting
         banner (dsa 141).
      C) Look for changes to greeting banner only every 3 minutes, rather than
         every 30 seconds.
      D) Changed to use ls_cp_info.(login connect)_info_dir.
      E) Make destroy -hold the default for the login-connect-loop request.
         Add -no_hold to counter -hold.  Allow -immediate for new_proc and
         destroy. (dsa 111)
      F) Add -auth to the dial request.
      G) Added login timeout handler to allow logins for only
         installation_parms.login_time seconds.  Add a wakeup loop count
         mechanism to detect high rate of wakeups (indicating comm line
         failure) and disconnect comm line. (dsa 70)
      H) Modified to make hello always print greeting banner, even at login
         request loop returned to by "logout -hold -brief".
      I) Correct coding standard violations.
      J) Add check for minimum password length.
      K) Add check for new password same as original password.
      L) Generate passwords whose length is specified by
         installation_parms.password_gpw_length and .password_min_length.
      M) Avoid telling Initializer when login fails because of too many
         bad passwords. (dsa 154)
      N) Prompt for login args when user just types "login", "enter" or
         "enterp". (dsa 135)
  3) change(87-04-16,GDixon), approve(87-06-25,MCR7702),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Include LS_RESPONSE_TYPES value in Unexpected response error message.
      B) Include time of last bad password in incorrect_passwords warning.
      C) Copy login_server_operator_response.process_group_id into
         ls_process_info for operator logins, so process_group_id will be
         correct in connection list.
      D) Add login_server_validate_request.connection_info.line_type. (dsa 123)
      E) Upgraded for change to answer_table.incl.pl1.
      F) Add support for login_server_process_request.minimum_ring, setting it
         to the minimum ring for DSA (ring 2).  This enforces the limitation in
         dsa 208.
  4) change(87-05-05,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Don't attempt to call ssu_$abort_subsystem in io_error on unit until
         after ssu_$listen has been called.  Otherwise, ssu_ will attempt to
         print a message on the terminal, causing another io_error (thus
         looping to get oob_stack).
  5) change(87-05-07,GDixon), approve(87-06-25,MCR7702),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Make LOGIN_TIMEOUT handler correctly check ls_validate.info.state to
         determine if hangup is needed.
      B) Changed MINIMUM_DSA_RING to 2.
  6) change(87-05-14,GDixon), approve(87-06-25,MCR7702),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Copy login_server_process_response.brief into ls_validate_info.brief.
      B) Change list request to print initial ring and authorization of
         disconnected processes, and use table format.
      C) Add cleanup handler to delete Initializer reply event channel.
      D) Allow process termination (eg, operator bump) after user is logged in
         but before process creation.
      E) Consolidate handling of validate_response in a new internal proc.
      F) Remove access_class_range from our calling sequence.
      G) Use ls_connection_desc.access_class_range and .minimum_ring instead.
      H) Add connection_info to login_server_list_request structure.
  7) change(87-05-26,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Use new ls_report_subr_error_ calling sequence.  Avoid lsdumps for
         some, "expected" errors.
  8) change(87-06-08,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Change Parse_login_args to remove -hd as short name for -hold.  This
         program (and the documentation) says -hd is short name for
         -home_dir.
  9) change(87-06-13,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Correctly diagnose io_error condition when going to NO_SETUP label
         from io_error on unit.
      B) Similarly, diagnose "iox_$control terminal_info" when going there
         from Read_answerback internal proc.
 10) change(87-06-26,GDixon), approve(87-06-26,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Change -printer_off/-no_printer_off to match parse_login_line_'s
         -print_off/-no_print_off.
      B) Add these control args to the dial preaccess command.
 11) change(87-07-06,GDixon), approve(87-07-06,MCR7679),
     audit(87-07-10,Parisek), install(87-08-04,MR12.1-1055):
      A) Fix bug in handling of enter and enterp preaccess commands.  These
         commands were never getting forwarded to the Initializer.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */
ls_validate_user_:
     procedure (a_ls_cp_info_ptr, a_ls_validate_options_ptr,
	a_process_info_ptr, a_code);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This procedure engages in the login dialogue with the user, and exchanges */
/* requests/responses with the Initializer in order to get a process created */
/* or reconnected, etc.					       */
/*							       */
/* A non-zero status code is returned if and only if the connection is       */
/* terminated.						       */
/*							       */
/* The login dialogue is implemented as an ssu_ subsystem, wherein the       */
/* various preaccess and access requests are subsystem requests.  The	       */
/* "unknown_request" procedure is replaced in order to check for a special   */
/* session login word.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* PARAMETERS */

dcl  a_arg_list_ptr pointer parameter;
dcl  a_code fixed bin (35) parameter;
dcl  a_cond_name char (*) parameter;			/* for timer call routine -- not used */
dcl  a_continue_sw bit (1) aligned parameter;
dcl  a_data_ptr pointer parameter;
dcl  a_info_ptr pointer parameter;
dcl  a_ls_cp_info_ptr pointer parameter;
dcl  a_ls_validate_options_ptr pointer parameter;
dcl  a_mc_ptr pointer parameter;			/* for timer call routine -- not used */
dcl  a_process_info_ptr pointer parameter;
dcl  a_request_name char (*) parameter;
dcl  a_sci_ptr pointer parameter;
dcl  a_wc_ptr pointer parameter;			/* for timer call routine -- not used */


/* AUTOMATIC */

dcl  anonymous bit (1) aligned;
dcl  answer char (3);
dcl  arg_list_ptr pointer;
dcl  argl fixed bin (21);
dcl  argp pointer;
dcl  auth_range_string char (512);
dcl  code fixed bin (35);
dcl  dial_person char (22);
dcl  dial_project char (9);
dcl  gpw_length fixed bin;
dcl  hangup_flag bit (1) aligned;
dcl  help_flag bit (1) aligned;
dcl  hold bit (1) aligned;
dcl  new_password char (8) aligned;
dcl  new_password_generated char (8);
dcl  new_password_hyphenated char (12);
dcl  period_index fixed bin;
dcl  process_request_size fixed bin (18);
dcl  quit_flag bit (1) aligned;
dcl  request_name char (32);
dcl  sci_ptr pointer;
dcl  second_new_password char (8) aligned;
dcl  subr_name char (64);
dcl  this_arg fixed bin;
dcl  user_specified bit (1);


/* AUTOMATIC STRUCTURES */

dcl  1 auto_as_user_message_info aligned like as_user_message_info;
dcl  1 auto_dial_request aligned like login_server_dial_request;
dcl  1 auto_hangup_request aligned like login_server_disconnect_request;
dcl  1 auto_logout_request aligned like login_server_logout_request;
dcl  1 auto_rp_options aligned like rp_options;
dcl  1 auto_validate_info aligned like ls_validate_info;
dcl  1 auto_validate_request aligned like login_server_validate_request;


/* The following declarations are grouped together because they are all
   "global" variables set by Parse_login_args in response to control arguments
   on the initial request line.
*/

dcl  auth_specified bit (1) aligned;
dcl  authorization bit (72) aligned;
dcl  brief bit (1) aligned;
dcl  brief_specified bit (1) aligned;
dcl  cda bit (1) aligned;
dcl  cdp bit (1) aligned;
dcl  change_password bit (1) aligned;
dcl  command_type fixed bin;
dcl  first_arg_arg fixed bin;				/* position in argument list of first arg after "-args" */
dcl  force bit (1) aligned;
dcl  force_specified bit (1) aligned;
dcl  generate_password bit (1) aligned;
dcl  hold_given bit (1) aligned;
dcl  hold_on_destroy bit (1) aligned;
dcl  home_dir char (168);
dcl  immediate bit (1) aligned;
dcl  mask_needed bit (1) aligned;
dcl  mode_string char (512);
dcl  no_start_up bit (1) aligned;
dcl  number_of_args fixed bin;
dcl  operator bit (1) aligned;
dcl  outer_module char (32);
dcl  person_name char (22);
dcl  preempt bit (1) aligned;
dcl  preempt_specified bit (1) aligned;
dcl  process_number fixed bin;
dcl  process_overseer char (168);
dcl  project_name char (9);
dcl  ring fixed bin;
dcl  ring_specified bit (1) aligned;
dcl  save bit (1) aligned;
dcl  save_specified bit (1) aligned;
dcl  subsystem char (168);
dcl  terminal_id char (4);
dcl  terminal_type char (32);
dcl  virtual_channel_name char (32);
dcl  warn bit (1) aligned;
dcl  warn_specified bit (1) aligned;


/* BASED */

dcl  arg char (argl) based (argp);
dcl  system_area area based (system_areap);


/* ENTRIES */

dcl  check_password_ entry (char (*), char (*), fixed bin (35));
dcl  convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_authorization_$to_string_range entry ((2) bit (72) aligned, char (*), fixed bin (35));
dcl  cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
						/** */
dcl  dsa_log_manager_$trace_message entry options (variable);
	/*** */
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  date_time_$format_max_length entry (char (*), char (*), char (*)) returns (fixed bin);
dcl  generate_word_ entry (char (*), char (*), fixed bin, fixed bin);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  ioa_ entry () options (variable);
dcl  ioa_$nnl entry () options (variable);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin(71), fixed bin(35));
dcl  ls_convert_as_error_code_ entry (fixed bin (35)) returns (fixed bin (35));
dcl  ls_message_$print entry options (variable);
dcl  ls_message_$print_nnl entry options (variable);
dcl  ls_message_$print_error entry options (variable);
dcl  ls_report_internal_error_ entry options (variable);
dcl  ls_report_subr_error_ entry (fixed bin(35), char(*), ptr, char(*), bit(1) aligned, bit(1) aligned);
dcl  net_info_$get_field entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  scramble_ entry (char (8)) returns (char (8));
dcl  send_ls_request_ entry (ptr, fixed bin (18), ptr, fixed bin (35));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$abort_subsystem entry () options (variable);
dcl  ssu_$add_info_dir entry (ptr, char (*), fixed bin, fixed bin (35));
dcl  ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_list_ptr entry (ptr, ptr);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  ssu_$cpescape_disabled entry options (variable);
dcl  ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
dcl  ssu_$delete_info_dir entry (ptr, char (*), fixed bin (35));
dcl  ssu_$delete_request_table entry (ptr, ptr, fixed bin (35));
dcl  ssu_$destroy_invocation entry (ptr);
dcl  ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  ssu_$get_request_name entry (ptr) returns (char (32));
dcl  ssu_$get_info_ptr entry (ptr) returns (ptr);
dcl  ssu_$get_procedure entry (ptr, char (*), entry, fixed bin (35));
dcl  ssu_$get_request_processor_options entry (ptr, char (8), ptr, fixed bin (35));
dcl  ssu_$listen entry (ptr, ptr, fixed bin (35));
dcl  ssu_$print_message entry () options (variable);
dcl  ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35));
dcl  ssu_$set_prompt_mode entry (ptr, bit (*));
dcl  ssu_$set_request_processor_options entry (ptr, ptr, fixed bin (35));
dcl  ssu_requests_$help entry options (variable);
dcl  system_info_$installation_id entry (char (*));
dcl  system_info_$sysid entry (char (*));
dcl  timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry, ptr);
dcl  timer_manager_$reset_alarm_call entry (entry, ptr);
dcl  ttt_info_$decode_answerback entry (char (*), fixed bin, char (*), char (4), fixed bin (35));
dcl  user_message_$read_message entry (ptr, ptr, fixed bin (35));


/* EXTERNAL STATIC */

dcl  (
     as_error_table_$no_connect_aclass,
     as_error_table_$no_such_process_msg
     ) fixed bin (35) external static;

dcl  (
     error_table_$action_not_performed,
     error_table_$bad_arg,
     error_table_$bad_conversion,
     error_table_$bad_mode,
     error_table_$badopt,
     error_table_$fatal_error,
     error_table_$inconsistent,
     error_table_$long_record,
     error_table_$noarg,
     error_table_$no_message,
     error_table_$smallarg,
     error_table_$timeout,
     error_table_$too_many_args,
     error_table_$unimplemented_version,
     error_table_$user_requested_hangup,
     error_table_$user_requested_logout,
     error_table_$wrong_no_of_args
     ) fixed bin (35) external static;

dcl  (
     iox_$user_input,
     iox_$user_io
     ) pointer external static;

dcl  ls_data_$suffix (0:9) char (4) external static;
dcl  ls_data_$teens_suffix (0:9) char (4) external static;

dcl  (
     ls_message_table_$aclass_banner_msg,
     ls_message_table_$already_logged_in,
     ls_message_table_$authorization,
     ls_message_table_$bad_password_check,
     ls_message_table_$bad_password_format,
     ls_message_table_$connect_requests,
     ls_message_table_$connected,
     ls_message_table_$connected_after_new_proc,
     ls_message_table_$cost_message,
     ls_message_table_$current_modes,
     ls_message_table_$current_terminal_id,
     ls_message_table_$current_terminal_type,
     ls_message_table_$default_auth_changed,
     ls_message_table_$default_project_changed,
     ls_message_table_$dial_connect_msg,
     ls_message_table_$dialed_to_mc,
     ls_message_table_$disconnected_processes,
     ls_message_table_$dropped_by_mc,
     ls_message_table_$generated_password,
     ls_message_table_$generated_password_error,
     ls_message_table_$give_instructions,
     ls_message_table_$greeting_msg,
     ls_message_table_$hangup,
     ls_message_table_$help_gpw_verify,
     ls_message_table_$help_new_password,
     ls_message_table_$help_npw_verify,
     ls_message_table_$help_password,
     ls_message_table_$incorrect_passwords,
     ls_message_table_$last_login,
     ls_message_table_$list_process,
     ls_message_table_$list_proc_header,
     ls_message_table_$login,
     ls_message_table_$login_args,
     ls_message_table_$login_excess_wakeups,
     ls_message_table_$login_requests,
     ls_message_table_$login_timeout,
     ls_message_table_$logout,
     ls_message_table_$logout_disconnected,
     ls_message_table_$multiple_login_msg,
     ls_message_table_$must_give_process_no,
     ls_message_table_$new_password,
     ls_message_table_$new_password_again,
     ls_message_table_$new_password_error,
     ls_message_table_$new_password_indistinct,
     ls_message_table_$no_connect_aclass,
     ls_message_table_$no_disconnected_processes,
     ls_message_table_$no_such_process,
     ls_message_table_$password,
     ls_message_table_$password_changed,
     ls_message_table_$password_expired,
     ls_message_table_$password_format_warning,
     ls_message_table_$password_quit,
     ls_message_table_$password_unused_too_long,
     ls_message_table_$please_try_again,
     ls_message_table_$process_destroyed,
     ls_message_table_$requesting_dial_to_mc,
     ls_message_table_$special_session,
     ls_message_table_$user_required_for_dial
     ) fixed bin (35) external static;

dcl  ls_ssu_request_tables_$connect_requests fixed bin external static;
dcl  ls_ssu_request_tables_$enabled_standard_requests fixed bin external static;
dcl  ls_ssu_request_tables_$login_requests fixed bin external static;

dcl  (
     ssu_et_$program_interrupt,
     ssu_et_$request_line_aborted,
     ssu_et_$subsystem_aborted
     ) fixed bin (35) external static;

/* INTERNAL STATIC */

dcl  BS char (1) int static options (constant) initial (""); /* backspace */
dcl  CONSTANT_MASK char (72) internal static options (constant)
	initial ("QMQMQMQMQMQM" || (12)"" || "XWXWXWXWXWXW" || (12)"" || "986543435689" || (12)"");
						/* constant part of password mask -- contains backspaces between graphic strings */
dcl  DONT_FORCE_MESSAGE bit (1) int static options (constant) init ("0"b);
dcl  DONT_TAKE_DUMP bit (1) aligned int static options (constant) init ("0"b);
dcl  DONT_TELL_INITIALIZER bit (1) aligned int static options (constant) init ("0"b);
dcl  DONT_TELL_USER bit (1) aligned int static options (constant) init ("0"b);
dcl  DOT char (1) internal static options (constant) initial (".");
dcl  FALSE bit (1) int static options (constant) init ("0"b);
dcl  FORCE_MESSAGE bit (1) int static options (constant) init ("1"b);
dcl  HELP_GI_REQUEST char (17) internal static options (constant) initial ("help general_info");
dcl  HYPHEN char (1) internal static options (constant) initial ("-");
dcl  LARGE_NUMBER fixed bin internal static options (constant) initial (100000);
						/* for adding standard request table at end */
dcl  LS_DIALOGUE_NAME char (14) internal static options (constant) initial ("login_dialogue");
dcl  LS_DIALOGUE_VERSION char (4) internal static options (constant) initial ("1.0 ");
dcl  NL char (1) internal static options (constant) initial ("
");
dcl  ONE_MILLION fixed bin (35) internal static options (constant) initial (1000000);
dcl  OUR_NAME char (17) internal static options (constant) initial ("ls_validate_user_");
dcl  RANDOM_ALPHABET char (40) aligned int static init ("etaiosqwertyuioplkjhgfdsazxcvbnmqhpwygdj");
						/* For variable part of password mask */
dcl  SP char (1) int static options (constant) init (" ");
dcl  SPSP char (2) int static options (constant) init ("  ");
dcl  SPACE_SEMICOLON char (2) internal static options (constant) initial (" ;");
dcl  SYSTEM_DIAL_ID char (6) internal static options (constant) initial ("system");
dcl  SYSTEM_LOW bit (72) int static options (constant) init (""b);
dcl  TAKE_DUMP bit (1) aligned int static options (constant) init ("1"b);
dcl  TELL_INITIALIZER bit (1) aligned int static options (constant) init ("1"b);
dcl  TELL_USER bit (1) aligned int static options (constant) init ("1"b);
dcl  THREE_MINUTES fixed bin (71) internal static options (constant) initial (180000000);
dcl  TRUE bit (1) int static options (constant) init ("1"b);
dcl  system_areap pointer internal static initial (null ());


/* BUILTINS & CONDITIONS */

dcl  (addr, after, before, bit, clock, copy, currentsize, divide, float, hbound, index, lbound, length, max, mod, null,
     rank, rtrim, search, size, string, substr, translate, unspec) builtin;

dcl  (cleanup, io_error) condition;

	ls_cp_info_ptr = a_ls_cp_info_ptr;
	ls_validate_options_ptr = a_ls_validate_options_ptr;
	ls_process_info_ptr = a_process_info_ptr;

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

	ls_connection_desc_ptr = ls_cp_info.connection_desc_ptr;

	if ls_process_info.version ^= LS_PROCESS_INFO_V1
	then do;
	     a_code = error_table_$unimplemented_version;
	     return;
	end;

	unspec (auto_validate_info) = ""b;
	auto_validate_info.cp_info_ptr = ls_cp_info_ptr;
	auto_validate_info.options_ptr = ls_validate_options_ptr;
	auto_validate_info.process_info_ptr = ls_process_info_ptr;
	auto_validate_info.connection_desc_ptr = ls_cp_info.connection_desc_ptr;
	auto_validate_info.process_request_ptr = null ();
	auto_validate_info.brief = ls_validate_options.brief;
	auto_validate_info.minimum_ring = ls_connection_desc.minimum_ring;
	auto_validate_info.connection_name = ls_connection_desc.name;
	auto_validate_info.access_class_range = ls_connection_desc.access_class_range;
	ls_validate_info_ptr = addr (auto_validate_info);
	call Change_state (JUST_CONNECTED);

	sci_ptr = null ();
	on cleanup
	     begin;
	     if ls_validate_info.process_request_ptr ^= null ()
						/* which means lower-level cleanup handler didn't get it */
	     then free ls_validate_info.process_request_ptr -> login_server_process_request in (system_area);

	     if auto_validate_info.reply_channel ^= 0 then
		call ipc_$delete_ev_chn (auto_validate_info.reply_channel,
		code);

	     if sci_ptr ^= null ()
	     then call ssu_$destroy_invocation (sci_ptr);

	     call Change_state (DISCONNECTED);
	end;

	call ssu_$create_invocation (LS_DIALOGUE_NAME, LS_DIALOGUE_VERSION, addr (auto_validate_info),
	     addr (ls_ssu_request_tables_$login_requests), ls_cp_info.login_info_dir, sci_ptr, code);

	if code ^= 0
	then do;
	     call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		"ssu_$create_invocation", TELL_USER, TAKE_DUMP);
	     call Hangup (DONT_TELL_INITIALIZER);
	     a_code = code;
	     return;
	end;

	auto_validate_info.sci_ptr = sci_ptr;

	call ssu_$set_procedure (sci_ptr, "cpescape", ssu_$cpescape_disabled, code);
						/* don't want ".." escapes in login dialogue */
	if code ^= 0
	then do;
	     subr_name = "ssu_$set_procedure";
	     go to NO_SETUP;
	end;

	call ssu_$add_request_table (sci_ptr, addr (ls_ssu_request_tables_$enabled_standard_requests), LARGE_NUMBER,
	     code);
	if code ^= 0
	then do;
	     subr_name = "ssu_$add_request_table";
	     go to NO_SETUP;
	end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Disable iteration in requests.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call ssu_$get_request_processor_options (sci_ptr, RP_OPTIONS_VERSION_1, addr (auto_rp_options), code);
	if code ^= 0
	then do;
	     subr_name = "ssu$get_request_processor_options";
	     go to NO_SETUP;
	end;
	auto_rp_options.non_standard_language = "1"b;
	auto_rp_options.character_types (rank ("(")), auto_rp_options.character_types (rank (")")),
	     auto_rp_options.character_types (rank ("[")), auto_rp_options.character_types (rank ("]")),
	     auto_rp_options.character_types (rank (";")) = NORMAL_CHARACTER;
	call ssu_$set_request_processor_options (sci_ptr, addr (auto_rp_options), code);
	if code ^= 0
	then do;
	     subr_name = "ssu_$set_request_processor_options";
	     go to NO_SETUP;
	end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Setup procedure to look for special session login word.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call ssu_$set_procedure (sci_ptr, "unknown_request", unknown_request, code);
	if code ^= 0
	then do;
	     subr_name = "ssu_$set_procedure";
	     go to NO_SETUP;
	end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Establish procedure and data to measure wakeup frequency.  Login aborted  */
/* if the wakeups (incoming lines) are too frequent.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	ls_validate_info.wakeup_loop.recent_wakeup_time = clock ();
	ls_validate_info.wakeup_loop.recent_wakeup_count = 1;
	call ssu_$get_procedure (sci_ptr, "execute_line", ls_validate_info.wakeup_loop.real_execute_line, code);
	if code ^= 0
	then do;
	     subr_name = "ssu_$get_procedure";
	     go to NO_SETUP;
	end;
	call ssu_$set_procedure (sci_ptr, "execute_line", COUNT_WAKEUP_FOR_REQUEST_LINE, code);
	if code ^= 0
	then do;
	     subr_name = "ssu_$set_procedure";
	     go to NO_SETUP;
	end;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Turn off ssu_ prompting for request lines.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT | DONT_PROMPT_AFTER_NULL_LINES | DONT_PROMPT_IF_TYPEAHEAD);


	call ipc_$create_ev_chn (auto_validate_info.reply_channel, code);
						/* set up event channel for as_request replies */
	if code ^= 0
	then do;
	     subr_name = "ipc_$create_ev_chn";
	     go to NO_SETUP;
	end;

	auto_validate_info.server_handle = bit (clock (), 72);

	on io_error				/* connection must be gone, prior to entering */
	     begin;				/* ssu_$listen; we cannot call ssu_$abort_subsystem */
						/* here, for it would try to write on connection */
	     call Hangup_no_message (DONT_TELL_INITIALIZER);
	     ls_validate_info.code = error_table_$fatal_error;
	     subr_name = "io_error condition";
	     go to NO_SETUP;			/* calling ssu_$abort_subsystem here would cause */
						/* ssu_ to print message, causing resignal of */
	end;					/* io_error condition, and infinite loop! */

	if ^ls_validate_options.not_first | ^ls_process_info.terminal_info_set
	then call Read_answerback ();			/* this will also set initial terminal type */
						/* and do all the necessary mode-setting */
	else do;
	     auto_validate_info.user_connection_info.terminal_type = ls_process_info.terminal_type;
	     auto_validate_info.user_connection_info.terminal_id = ls_process_info.terminal_id;
	     auto_validate_info.user_connection_info.line_type = ls_process_info.line_type;
	end;

	call Write_greeting_message (DONT_FORCE_MESSAGE);

	call Change_state (AWAITING_INITIAL_REQUEST);

	on io_error				/* ready to enter ssu_$listen; can now call */
	     begin;				/* ssu_$abort_subsystem if connection is gone */
	     call Hangup_no_message (ls_validate_info.initializer_handle ^= ""b);
	     ls_validate_info.code = error_table_$fatal_error;
	     call ssu_$abort_subsystem (sci_ptr);
	end;

	call ssu_$listen (sci_ptr, null (), code);

	call Change_state (USER_VALIDATED);

	if ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, auto_validate_info.code,
		null (), 0, "", "(validate_info.code) returned from ssu_$listen.");

	if code = ssu_et_$subsystem_aborted
	then a_code = auto_validate_info.code;
	else do;
	     call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
		"ssu_$listen", DONT_TELL_USER, TAKE_DUMP);
	     a_code = code;
	end;

DESTROY:
          call ipc_$delete_ev_chn (auto_validate_info.reply_channel, code);
	call ssu_$destroy_invocation (sci_ptr);

	return;

NO_SETUP:
	call ls_report_subr_error_ (code, OUR_NAME, ls_cp_info_ptr,
	     subr_name, TELL_USER, TAKE_DUMP);
	call Hangup (DONT_TELL_INITIALIZER);
	a_code = code;
	go to DESTROY;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ALARM CALL HANDLERS					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* LOGIN_TIMEOUT:						       */
/*    alarm call triggered entry, called installation_parms.login_time       */
/*    seconds after starting to login, to cause the login attempt to	       */
/*    timeout.  If the user does not login within this many seconds, the     */
/*    connection is dropped.  It is an entry rather than an internal	       */
/*    procedure so that procedures it calls (eg, Hangup_with_error)	       */
/*    can remain quick.  It is also an entry rather than an internal proc    */
/*    so that it gets passed to timer_manager_ with a null environment ptr.  */
/*    This allows any invocation of ls_validate_user_ (eg, the one calling   */
/*    ssu_$listen, the one invoked for each request, the one invoked for     */
/*    an alarm call) to reset the timer, and establish a new timer than any  */
/*    other invocation can later reset.				       */
/* LOGIN_TIMEOUT_CHECK:					       */
/*    establishes the alarm call timer for login timeouts.		       */
/* LOGIN_TIMEOUT_CHECK_stop:					       */
/*    turns off the alarm call.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

LOGIN_TIMEOUT:
     entry (a_mc_ptr, a_cond_name, a_wc_ptr, a_data_ptr);
	ls_validate_info_ptr = a_data_ptr;
	if login_timeout_check_required (ls_validate_info.state)
	then do;
	     sci_ptr = ls_validate_info.sci_ptr;
	     ls_cp_info_ptr = ls_validate_info.cp_info_ptr;
	     ip = ls_cp_info.installation_parms_ptr;
	     call ls_message_$print (ls_message_table_$login_timeout, Minutes (installation_parms.login_time),
		Minutes (installation_parms.login_time) ^= 1.0);
	     call Hangup_with_error (error_table_$timeout, DONT_TELL_INITIALIZER);
	end;
	else ;					/* ignore timeout if login just completed. */
	return;


LOGIN_TIMEOUT_CHECK:
     procedure;
	ip = ls_cp_info.installation_parms_ptr;
	call timer_manager_$alarm_call ((installation_parms.login_time), RELATIVE_SECONDS, LOGIN_TIMEOUT,
	     ls_validate_info_ptr);
	return;
LOGIN_TIMEOUT_CHECK_stop:
     entry;
	call timer_manager_$reset_alarm_call (LOGIN_TIMEOUT, ls_validate_info_ptr);
     end LOGIN_TIMEOUT_CHECK;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PRINT_BANNER_IF_CHANGED:					       */
/*    alarm call triggered entry, called every 3 minutes to check if	       */
/*    greeting banner changes so the new banner can be printed on the	       */
/*    connection if it's still waiting for the login request.  It is an      */
/*    entry rather than an internal procedure so that procedures it calls    */
/*    (eg, Write_greeting_message) can remain quick.		       */
/* PRINT_CHANGED_BANNER:					       */
/*    checks for change, and actually prints the banner.		       */
/* WATCH_FOR_CHANGED_BANNER:					       */
/*    turns on the alarm call.				       */
/* WATCH_FOR_CHANGED_BANNER_stop:				       */
/*    turns off the alarm call.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

PRINT_BANNER_IF_CHANGED:
     entry (a_mc_ptr, a_cond_name, a_wc_ptr, a_data_ptr);

	ls_validate_info_ptr = a_data_ptr;
	call PRINT_CHANGED_BANNER ();
	return;



PRINT_CHANGED_BANNER:
     procedure;

	if ls_validate_info.state = AWAITING_INITIAL_REQUEST
	then do;
	     if ls_validate_info.cp_info_ptr -> ls_cp_info.answer_table_ptr -> anstbl.message_update_time
		> ls_validate_info.banner_checked_time
	     then do;
		call ioa_ ("");			/* put out blank line */
		call Write_greeting_message (FORCE_MESSAGE);
		call iox_$control (iox_$user_io, "start", null (), (0));
	     end;					/* in case this is necessary */
	     call WATCH_FOR_CHANGED_BANNER ();
	end;
     end PRINT_CHANGED_BANNER;


WATCH_FOR_CHANGED_BANNER:
     procedure;
	ls_validate_info.banner_checked_time = clock ();
	call timer_manager_$alarm_call (THREE_MINUTES, RELATIVE_MICROSECONDS, PRINT_BANNER_IF_CHANGED,
	     ls_validate_info_ptr);
	return;

WATCH_FOR_CHANGED_BANNER_stop:
     entry;
	call timer_manager_$reset_alarm_call (PRINT_BANNER_IF_CHANGED, ls_validate_info_ptr);
     end WATCH_FOR_CHANGED_BANNER;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/*  SSU_ REPLACEMENT PROCEDURES				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* COUNT_WAKEUP_FOR_REQUEST_LINE:				       */
/* This is a replacement for the ssu_$execute_line procedure.  It is invoked */
/* for each request line (eg, login) typed by the user.		       */
/* 1) Check for excessive incoming wakeups.			       */
/* 2) If high rate found, hangup the terminal.			       */
/* 3) Otherwise, execute the request line via the normal ssu_ mechanisms.    */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

COUNT_WAKEUP_FOR_REQUEST_LINE:
     entry (a_sci_ptr, a_request_line_ptr, a_request_line_len, a_code);

dcl  a_request_line_ptr ptr parameter;
dcl  a_request_line_len fixed bin (21) parameter;

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = ssu_$get_info_ptr (sci_ptr);
	call Count_wakeups ();
	call ls_validate_info.wakeup_loop.real_execute_line (a_sci_ptr, a_request_line_ptr, a_request_line_len, a_code);
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* LOGIN REQUESTS:						       */
/*   access_class, acc   enter, e     hello      noecho		       */
/*   dial, d             enterp, ep   login, l   terminal_id, tid	       */
/*   echo                hangup       modes      terminal_type, ttp	       */
/*							       */
/* In addition, the "unknown_request" handler in included in this group, to  */
/* field special session logins that use a system-generated login number or  */
/* operator-specified login word.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

access_class:
     entry (a_sci_ptr, a_info_ptr);

/* display the connection's access class range */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call ssu_$arg_count (sci_ptr, number_of_args);	/* there shouldn't be any */
	if number_of_args ^= 0
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "This request takes no arguments.");

	ls_connection_desc_ptr = ls_validate_info.connection_desc_ptr;
	call convert_authorization_$to_string_range (ls_connection_desc.access_class_range, auth_range_string, code);

	if code ^= 0 & code ^= error_table_$smallarg
	then call ls_report_subr_error_ (code, OUR_NAME,
	     ls_validate_info.cp_info_ptr,
	     "convert_authorization_$to_string_range", TELL_USER, TAKE_DUMP);
	else call ls_message_$print (ls_message_table_$aclass_banner_msg, auth_range_string);

	return;

dial:
     entry (a_sci_ptr, a_info_ptr);

/* the "dial" request is for connection as a "slave" to an existing process, identified
   by a dial qualifier and optionally by a user ID. The user entering the dial
   request may also identify himself (or may be required to do so) by means of
   the -user control argument.
*/

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call ssu_$arg_list_ptr (sci_ptr, arg_list_ptr);
	call Parse_dial_args ();
	ls_validate_info.mask_needed = mask_needed;

	ls_request_ptr, ls_response_ptr = null ();
	on cleanup call Cleanup_handler ();

	ls_process_info_ptr = ls_validate_info.process_info_ptr;
	ls_process_info.server_handle = ls_validate_info.server_handle;

	if user_specified
	then do;					/* have to get password and validate user */
	     ls_request_ptr = addr (auto_validate_request);

	     call Get_initial_password (code);

	     if code ^= 0
	     then go to RESTART_DIAL;

	     login_server_validate_request.person_id = dial_person;
	     login_server_validate_request.project_id = dial_project;
	     login_server_validate_request.authorization = authorization;
	     login_server_validate_request.terminate_event_channel =
		ls_validate_info.connection_desc_ptr -> ls_connection_desc.terminate_event_channel;
	     login_server_validate_request.network_connection_type = NETWORK_CONNECTION_LOGIN;
	     string (login_server_validate_request.flags) = ""b;
	     login_server_validate_request.auth_given = auth_specified;
	     login_server_validate_request.connection_info = ls_validate_info.user_connection_info;

	     call Send_request_to_initializer (LS_VALIDATE_REQUEST,
		LS_VALIDATE_REQUEST_VERSION_1,
		size (login_server_validate_request), "0"b,
		LS_VALIDATE_RESPONSE, ls_response_ptr, code);

	     call Process_validate_response (code);

	     ls_validate_info.initializer_handle =
		login_server_validate_response.handle;
	     ls_process_info.initializer_handle =
		ls_validate_info.initializer_handle;
	     dial_person = login_server_validate_response.person_id;
	     dial_project = login_server_validate_response.project_id;

	     free login_server_validate_response in (system_area);
	end;

	else do;					/* didn't say -user */
	     ls_validate_info.initializer_handle = ""b;	/* to make sure we start clean */
	     dial_person, dial_project = "";

	     if ls_validate_info.dial_id = SYSTEM_DIAL_ID
	     then go to USER_REQUIRED;		/* "dial system" always requires -user */

	     call net_info_$get_field ("endpoint",
		(ls_validate_info.connection_desc_ptr -> ls_connection_desc.endpoint_name),
		"user_required_for_dial", answer, code);
	     if code ^= 0
	     then do;
		call ls_report_subr_error_ (code, OUR_NAME,
		     ls_validate_info.cp_info_ptr, "net_info_$get_field",
		     TELL_USER, TAKE_DUMP);
		go to RESTART_DIAL;
	     end;

	     else if answer = "yes"
	     then do;
USER_REQUIRED:
		call ls_message_$print (
		     ls_message_table_$user_required_for_dial);
		go to RESTART_DIAL;
	     end;

	     ls_process_info.initializer_handle = ""b;	/* no UTE was created */
	end;

	if ls_validate_info.dial_id = SYSTEM_DIAL_ID
	then do;					/* "system" is special -- treat like operator login */
	     call Login_operator (dial_person, dial_project, "", code);
	     if code ^= 0
	     then go to RESTART_DIAL;
	end;

	else do;
	     ls_request_ptr = addr (auto_dial_request);

	     login_server_dial_request.initializer_handle = ls_validate_info.initializer_handle;
	     login_server_dial_request.terminate_event_channel =
		ls_validate_info.connection_desc_ptr ->
		ls_connection_desc.terminate_event_channel;
	     login_server_dial_request.dial_qualifier =
		ls_validate_info.dial_id;
	     login_server_dial_request.person_id =
		ls_validate_info.person_id;
	     login_server_dial_request.project_id =
		ls_validate_info.project_id;
	     login_server_dial_request.connection_info =
		ls_validate_info.user_connection_info;
	     login_server_dial_request.user_person_id = dial_person;
	     login_server_dial_request.user_project_id = dial_project;

	     call Send_request_to_initializer (LS_DIAL_REQUEST, LS_DIAL_REQUEST_VERSION_1,
		size (login_server_dial_request), "0"b, LS_DIAL_RESPONSE, ls_response_ptr, code);

	     if code ^= 0
	     then do;
		call ssu_$print_message (sci_ptr, code);
		if ls_response_ptr ^= null ()
		then free login_server_dial_response in (system_area);
		go to RESTART_DIAL;
	     end;

/* now look at response and see if it worked */

	     if login_server_dial_response.status_code ^= 0
	     then do;
		ls_validate_info.code = ls_convert_as_error_code_ (
		     login_server_dial_response.status_code);
		call ls_message_$print_error (ls_validate_info.code);
		hangup_flag = login_server_dial_response.disconnect;

		free login_server_dial_response in (system_area);

		if hangup_flag
		then call Hangup_with_error (ls_validate_info.code, DONT_TELL_INITIALIZER);
		else go to RESTART_DIAL;
	     end;

/* otherwise, all is well, pass it back  */

	     ls_validate_info.code = 0;
	     ls_process_info.process_group_id =
		login_server_dial_response.process_group_id;
	     ls_process_info.start_event_channel =
		login_server_dial_response.start_event_channel;
	     ls_process_info.authorization =
		login_server_dial_response.authorization;
	     ls_process_info.process_id =
		login_server_dial_response.process_id;
	     ls_process_info.initial_ring =
		login_server_dial_response.process_ring;
	     ls_process_info.usage_type = LS_DIAL_USAGE;
	     ls_process_info.terminal_type = ls_validate_info.
		user_connection_info.terminal_type;
	     ls_process_info.terminal_id = ls_validate_info.
		user_connection_info.terminal_id;
	     ls_process_info.line_type = ls_validate_info.
		user_connection_info.line_type;
	     ls_process_info.flags.terminal_info_set = "1"b;

	     call ls_message_$print (ls_message_table_$dial_connect_msg,
		ls_validate_info.user_connection_info.terminal_type,
		ls_validate_info.user_connection_info.terminal_id,
		ls_process_info.process_group_id, date_time_$format (
		"system_time", clock (), "system_zone", "system_lang"));

	     free login_server_dial_response in (system_area);
	end;

	call ssu_$abort_subsystem (sci_ptr);		/* ALL DONE */
	return;

echo:
     entry (a_sci_ptr, a_info_ptr);

/* "echo" and "noecho" are pretty simple: just turn echoplex mode on or off */

	call Set_modes ("echoplex");
	return;



noecho:
     entry (a_sci_ptr, a_info_ptr);

	call Set_modes ("^echoplex");
	return;

enter:
     entry (a_sci_ptr, a_info_ptr);

/* "enter" request: create a process for an anonymous user */

	command_type = ENTER_REQ;
	go to ENTER_JOIN;


enterp:
     entry (a_sci_ptr, a_info_ptr);

/* "enterp" request: create a process for an anonymous user, but require a password */
	command_type = ENTERP_REQ;
ENTER_JOIN:
	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;
	ansp = ls_cp_info.answer_table_ptr;
	anonymous = "1"b;
	arg_list_ptr = null ();
	request_name = ssu_$get_request_name (sci_ptr);
	go to LOGIN_JOIN;

hangup:
     entry (a_sci_ptr, a_info_ptr);

/* the "hangup" request causes the breaking of the connection with no further action */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call Hangup ((ls_validate_info.initializer_handle ^= ""b));

	ls_validate_info.code = error_table_$user_requested_hangup;
	call ssu_$abort_subsystem (sci_ptr);
	return;

hello:
     entry (a_sci_ptr, a_info_ptr);

/* The "hello" request simply requests the (re)display of the "greeting" banner */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call Write_greeting_message (FORCE_MESSAGE);
	return;					/* with no change of state */

help:
     entry (a_sci_ptr, a_info_ptr);

/* Normally this entry simply passes the help request along to the standard request; with
   no arguments, however, it translates it into a line that will cause the standard
   request to print the "general_info" info.
*/

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call ssu_$arg_count (sci_ptr, number_of_args);

	if number_of_args > 0			/* normal help request */
	then call ssu_requests_$help (sci_ptr, ls_validate_info_ptr);

	else do;
	     call ssu_$execute_line (sci_ptr, addr (HELP_GI_REQUEST), length (HELP_GI_REQUEST), code);

	     if code ^= 0				/* if it's not one of the "standard" ones, */
						/* we'd better report it */
	     then if code ^= ssu_et_$request_line_aborted & code ^= ssu_et_$subsystem_aborted
		     & code ^= ssu_et_$program_interrupt
		then call ls_report_subr_error_ (code, OUR_NAME,
		     ls_validate_info.cp_info_ptr, "ssu_$execute_line",
		     TELL_USER, TAKE_DUMP);
	end;

	return;					/* no change of state */

login:
     entry (a_sci_ptr, a_info_ptr);

/* the entry to handle the "login" request. Also contains common code used by "enter" and "enterp",
   and is branched into by the unknown_request handler if the "unknown" request
   turns out to be the login word.
*/

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;
	ansp = ls_cp_info.answer_table_ptr;
	arg_list_ptr = null ();
	anonymous = "0"b;
	command_type = LOGIN_REQ;
	request_name = ssu_$get_request_name (sci_ptr);

LOGIN_JOIN:					/* common for all of login, enter, enterp */
	if anstbl.login_word ^= "login" & anstbl.login_word ^= "l"
						/* oops, special session */
	then do;
	     call ls_message_$print (ls_message_table_$special_session);
	     go to TRY_AGAIN;
	end;

ACTUALLY_LOGIN:					/* we branch to here from unknown_request if it was */
						/* a special-session login word */
	ls_request_ptr, ls_response_ptr = null ();
	on cleanup call Cleanup_handler ();

	if arg_list_ptr = null ()
	then call ssu_$arg_list_ptr (sci_ptr, arg_list_ptr);

	call cu_$arg_count_rel (number_of_args, arg_list_ptr, (0));
	if number_of_args < 1
	then do;
	     call Get_and_process_login_args (TRY_AGAIN);
	     return;
	end;

	call Parse_login_args ();
	if terminal_type ^= ""			/* user specified terminal type */
	then call Set_terminal_type (terminal_type);
	if mode_string ^= ""			/* user specified modes */
	then call Set_modes (mode_string);

	if terminal_id ^= ""
	then call Set_term_id (terminal_id);

	ls_validate_info.brief = brief;
	ls_validate_info.mask_needed = mask_needed;

	ls_request_ptr = addr (auto_validate_request);

	if command_type ^= ENTER_REQ			/* if password required */
	then do;
	     call Get_initial_password (code);
	     if code ^= 0
	     then go to RESTART_LOGIN;

	     if generate_password
	     then do;
		ip = ls_cp_info.installation_parms_ptr;
		gpw_length = max (installation_parms.password_gpw_length, installation_parms.password_min_length, 1);
REGENERATE_PASSWORD:
		call generate_word_ (new_password_generated, new_password_hyphenated, gpw_length,
		     length (new_password));
		new_password = scramble_ (new_password_generated);
		if login_server_validate_request.current_password = new_password
		then go to REGENERATE_PASSWORD;
		call ls_message_$print (ls_message_table_$generated_password, new_password_generated,
		     new_password_hyphenated);
		new_password_generated, new_password_hyphenated = "";

CHECK_GENERATED_PASSWORD:
		call ls_message_$print_nnl (ls_message_table_$new_password);
		call Get_password (second_new_password, quit_flag, help_flag, code);

		if quit_flag
		then go to RESTART_LOGIN;
		else if help_flag
		then do;
		     call ls_message_$print (ls_message_table_$help_gpw_verify);
		     go to CHECK_GENERATED_PASSWORD;
		end;

		else if code ^= 0 | second_new_password ^= new_password
		then do;
		     call ls_message_$print (ls_message_table_$generated_password_error);
		     go to CHECK_GENERATED_PASSWORD;
		end;
	     end;

	     else if change_password
	     then do;
GET_NEW_PASSWORD:
		call ls_message_$print_nnl (ls_message_table_$new_password);
		call Get_password (new_password, quit_flag, help_flag, code);

		if code ^= 0
		then go to RESTART_LOGIN;
		else if quit_flag
		then go to RESTART_LOGIN;
		else if help_flag
		then do;
		     call ls_message_$print (ls_message_table_$help_new_password);
		     go to GET_NEW_PASSWORD;
		end;

		if login_server_validate_request.current_password = new_password
		then do;
		     call ls_message_$print (ls_message_table_$new_password_indistinct);
		     go to RESTART_LOGIN;
		end;

NEW_PASSWORD_AGAIN:
		call ls_message_$print_nnl (ls_message_table_$new_password_again);
		call Get_password (second_new_password, quit_flag, help_flag, code);

		if code ^= 0
		then go to RESTART_LOGIN;
		else if quit_flag
		then go to RESTART_LOGIN;
		else if help_flag
		then do;
		     call ls_message_$print (ls_message_table_$help_npw_verify);
		     go to NEW_PASSWORD_AGAIN;
		end;

		if second_new_password ^= new_password
		then do;
		     call ls_message_$print (ls_message_table_$new_password_error);
		     go to GET_NEW_PASSWORD;
		end;
	     end;
	end;

/* we have ID and password (if any), now send validate request */

	login_server_validate_request.person_id = person_name;
	login_server_validate_request.project_id = project_name;
	login_server_validate_request.connection_info = ls_validate_info.user_connection_info;
	login_server_validate_request.terminal_id = ls_validate_info.user_connection_info.terminal_id;
	login_server_validate_request.authorization = authorization;
	login_server_validate_request.terminate_event_channel =
	     ls_validate_info.connection_desc_ptr -> ls_connection_desc.terminate_event_channel;
	login_server_validate_request.network_connection_type = NETWORK_CONNECTION_LOGIN;
	login_server_validate_request.gpw = generate_password;
	login_server_validate_request.auth_given = auth_specified;
	login_server_validate_request.anonymous = (command_type = ENTERP_REQ);
	login_server_validate_request.anon_no_password = (command_type = ENTER_REQ);
	login_server_validate_request.change_password = change_password | generate_password;
	login_server_validate_request.change_default_auth = cda;
	login_server_validate_request.change_default_proj = cdp;
	login_server_validate_request.operator = operator;
	login_server_validate_request.pad = ""b;
	login_server_validate_request.new_password = new_password;

	call Send_request_to_initializer (LS_VALIDATE_REQUEST, LS_VALIDATE_REQUEST_VERSION_1,
	     size (login_server_validate_request), "0"b, LS_VALIDATE_RESPONSE, ls_response_ptr, code);

	call Process_validate_response (code);

	ls_validate_info.initializer_handle =
	     login_server_validate_response.handle;
	ls_validate_info.person_id =
	     login_server_validate_response.person_id;
	ls_validate_info.project_id =
	     login_server_validate_response.project_id;
	ls_validate_info.n_disconnected_processes =
	     login_server_validate_response.n_disconnected_processes;
	ls_validate_info.previous_login_info =
	     login_server_validate_response.previous_login_info;

	ls_process_info_ptr = ls_validate_info.process_info_ptr;
	ls_process_info.authorization =
	     login_server_validate_response.authorization;
	ls_process_info.server_handle = ls_validate_info.server_handle;
	ls_process_info.initializer_handle =
	     ls_validate_info.initializer_handle;

	free login_server_validate_response in (system_area);

	if operator
	then do;					/* use operator request instead of process request */
	     call Login_operator ((ls_validate_info.person_id), (ls_validate_info.project_id), virtual_channel_name,
		code);
	     if code ^= 0
	     then go to TRY_AGAIN;

	     else call ssu_$abort_subsystem (sci_ptr);	/* we're finished */
	end;

	else do;

/* now we're ready to set up create request. First we have to get the login args (subject of -arguments arg) if any */

	     ls_process_request_n_args = number_of_args - first_arg_arg + 1;
	     if ls_process_request_n_args = 0
	     then ls_process_request_arg_string_length = 0;
	     else ls_process_request_arg_string_length = Get_total_arg_length ();

	     process_request_size = size (login_server_process_request);
						/* allowing for args */
	     allocate login_server_process_request in (system_area) set (ls_request_ptr);
	     ls_validate_info.process_request_ptr = ls_request_ptr;

/* now fill in the actual args */

	     call Get_arg_args ();
	     call Fill_in_process_request (command_type);

	     if command_type = LIST_REQ
	     then call List_request ();
	     else if command_type = ENTER_REQ | command_type = ENTERP_REQ
	     then do;				/* anonymous proc*/
						/* cannot be     */
						/* disconnected  */
		call Send_request_to_initializer (LS_PROCESS_REQUEST, LS_PROCESS_REQUEST_VERSION_1,
		     currentsize (login_server_process_request), "0"b, LS_PROCESS_RESPONSE, ls_response_ptr, code);

		call Process_process_response (code);
	     end;
	     else do;				/* login, create */
						/* et al can have*/
						/* disconnected  */
						/* processes.    */
		if ls_validate_info.n_disconnected_processes > 0
		then do;
		     call ls_message_$print (ls_message_table_$disconnected_processes,
			ls_validate_info.n_disconnected_processes, (ls_validate_info.n_disconnected_processes > 1));

		     if command_type ^= CREATE_REQ
		     then if command_type = LOGIN_REQ | ls_validate_info.n_disconnected_processes < process_number
			then do;
			     if command_type = LOGIN_REQ
			     then call ls_message_$print (ls_message_table_$give_instructions);
			     else call ls_message_$print (ls_message_table_$no_such_process, process_number);
			     call Enter_connect_loop ();
			     return;
			end;

			else if ls_validate_info.n_disconnected_processes > 1
			then if process_number = 0	/* process number omitted, ambiguous */
			     then do;
				call ls_message_$print (ls_message_table_$must_give_process_no);
				call Enter_connect_loop ();
				return;
			     end;
		end;

		else if command_type ^= LOGIN_REQ & command_type ^= CREATE_REQ
		then do;
		     call ls_message_$print (ls_message_table_$no_disconnected_processes);
		     call Enter_connect_loop ();
		     return;
		end;

		call Send_request_to_initializer (LS_PROCESS_REQUEST, LS_PROCESS_REQUEST_VERSION_1,
		     currentsize (login_server_process_request), "0"b, LS_PROCESS_RESPONSE, ls_response_ptr, code);

		call Process_process_response (code);
	     end;

	     return;
	end;

RESTART_LOGIN:
RESTART_DIAL:
TRY_AGAIN:
	call ls_message_$print (ls_message_table_$please_try_again);
	call Change_state (AWAITING_INITIAL_REQUEST);
	return;					/*  back to ssu_ listener */

modes:
     entry (a_sci_ptr, a_info_ptr);

/* set or print the terminal modes */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call ssu_$arg_count (sci_ptr, number_of_args);
	if number_of_args > 1
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args);

	if number_of_args = 0
	then do;
	     call iox_$modes (iox_$user_io, "", mode_string, code);
	     if code ^= 0
	     then call ls_report_subr_error_ (code, OUR_NAME,
		ls_validate_info.cp_info_ptr, "iox_$modes", TELL_USER,
		DONT_TAKE_DUMP);

	     else call ls_message_$print (ls_message_table_$current_modes, mode_string);
	end;

	else do;
	     call ssu_$arg_ptr (sci_ptr, 1, argp, argl);
	     call Set_modes (arg);
	end;

	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* The slave request is left over from the old answering service, and is not */
/* applicable in this context.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

slave:
     entry (a_sci_ptr, a_info_ptr);

	sci_ptr = a_sci_ptr;

	call ssu_$abort_line (sci_ptr, 0, "The ""slave"" request is not available on this type of connection.");
	return;

terminal_id:
     entry (a_sci_ptr, a_info_ptr);

/* set or print the terminal ID */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call ssu_$arg_count (sci_ptr, number_of_args);
	if number_of_args > 1
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args);

	if number_of_args = 0
	then call ls_message_$print (ls_message_table_$current_terminal_id,
		ls_validate_info.user_connection_info.terminal_id);

	else do;
	     call ssu_$arg_ptr (sci_ptr, 1, argp, argl);
	     call Set_term_id (arg);
	end;

	return;

terminal_type:
     entry (a_sci_ptr, a_info_ptr);

/* set or print the terminal type */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;

	call ssu_$arg_count (sci_ptr, number_of_args);
	if number_of_args > 1
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args);

	if number_of_args = 0
	then call ls_message_$print (ls_message_table_$current_terminal_type,
		ls_validate_info.user_connection_info.terminal_type);

	else do;
	     call ssu_$arg_ptr (sci_ptr, 1, argp, argl);
	     call Set_terminal_type (arg);
	end;

	return;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* unknown request handler: it might be that the "unknown" request is	       */
/*   actually a special-session login word.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

unknown_request:
     entry (a_sci_ptr, a_info_ptr, a_request_name, a_arg_list_ptr, a_continue_sw);

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;
	ansp = ls_cp_info.answer_table_ptr;
	arg_list_ptr = a_arg_list_ptr;
	request_name = a_request_name;
	anonymous = "0"b;
	command_type = LOGIN_REQ;

	if anstbl.login_word = request_name		/* equivalent of "login" */
	then do;
	     a_continue_sw = "1"b;			/* we'll handle it, thanks */
	     go to ACTUALLY_LOGIN;
	end;

	else a_continue_sw = "0"b;			/* really unknown */
	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CONNECT LOOP REQUESTS:					       */
/*   connect   destroy   logout				       */
/*   create    list      new_proc				       */
/*							       */
/* The following several request entry points implement "connect loop"       */
/* requests, and are only included in the request table used when in the     */
/* connect loop.  They behave very similarly, and most of their work is done */
/* by the internal procedure Connect_loop_process_request.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

connect:
     entry (a_sci_ptr, a_info_ptr);

/* connect to an existing disconnected process */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;

	ls_request_ptr, ls_response_ptr = null ();
	on cleanup call Cleanup_handler ();

	call Get_process_number ("0"b, "0"b, process_number, ("0"b), ("0"b));
	call Connect_loop_process_request (CONNECT_REQ, process_number, "0"b);
	return;


create:
     entry (a_sci_ptr, a_info_ptr);

/* create a new process */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;

	ls_request_ptr, ls_response_ptr = null ();
	on cleanup call Cleanup_handler ();

	call Connect_loop_process_request (CREATE_REQ, 0, "0"b);
	return;


destroy:
     entry (a_sci_ptr, a_info_ptr);

/* destroy a disconnected process */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;

	ls_request_ptr, ls_response_ptr = null ();
	on cleanup call Cleanup_handler ();

	call Get_process_number ("1"b, "1"b, process_number, immediate, hold_on_destroy);
	call Connect_loop_process_request (DESTROY_REQ, process_number, immediate);
	return;


list:
     entry (a_sci_ptr, a_info_ptr);

/* list the user's disconnected processes */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;

	call List_request ();
	return;

logout:
     entry (a_sci_ptr, a_info_ptr);

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;

	hold, brief = "0"b;
	call ssu_$arg_count (sci_ptr, number_of_args);

	do this_arg = 1 to number_of_args;
	     call ssu_$arg_ptr (sci_ptr, this_arg, argp, argl);

	     if index (arg, HYPHEN) ^= 1
	     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg);

	     if arg = "-hold" | arg = "-hd"
	     then hold = "1"b;

	     else if arg = "-no_hold" | arg = "-nhd"
	     then hold = "0"b;

	     else if arg = "-brief" | arg = "-bf"
	     then brief = "1"b;

	     else if arg = "-long" | arg = "-lg"
	     then brief = "0"b;

	     else call ssu_$abort_line (sci_ptr, error_table_$badopt, arg);
	end;

	if ls_validate_info.initializer_handle ^= ""b
	then do;					/* if initializer has ever heard of us, */
						/* tell it we're going away */
	     ls_request_ptr = addr (auto_logout_request);
	     login_server_logout_request.handle = ls_validate_info.initializer_handle;
	     login_server_logout_request.connection_info = ls_validate_info.user_connection_info;
	     call Send_request_to_initializer (LS_LOGOUT_REQUEST, LS_LOGOUT_REQUEST_VERSION_1,
		size (auto_logout_request), "0"b, 0, (null ()), code);
	end;

	if code ^= 0
	then call ssu_$print_message (sci_ptr, code);
	call Logout (^hold, brief, error_table_$user_requested_logout);
	return;

new_proc:
     entry (a_sci_ptr, a_info_ptr);

/* execute new_proc in disconnected process */

	sci_ptr = a_sci_ptr;
	ls_validate_info_ptr = a_info_ptr;
	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;

	ls_request_ptr, ls_response_ptr = null ();
	on cleanup call Cleanup_handler ();

	call Get_process_number ("1"b, "0"b, process_number, immediate, ("0"b));
	call Connect_loop_process_request (NEW_PROC_REQ, process_number, immediate);
	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INTERNAL PROCEDURES					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Change_state:						       */
/* 1) Set ls_validate_info.state to a new value.			       */
/* 2) If state is changing to AWAITING_INITIAL_REQUEST, establish timer to   */
/*    watch for a change to the login banner, and time login attempt.	       */
/* 3) If state is changing from AWAITING_INITIAL_REQUEST, turn off the       */
/*    timers.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Change_state:
     procedure (new_state);

dcl  new_state fixed bin;

	if ls_validate_info.state = new_state
	then ;
	else if new_state = AWAITING_INITIAL_REQUEST
	then call WATCH_FOR_CHANGED_BANNER ();
	else if ls_validate_info.state = AWAITING_INITIAL_REQUEST
	then call WATCH_FOR_CHANGED_BANNER_stop ();

	if login_timeout_check_required (ls_validate_info.state) = login_timeout_check_required (new_state)
	then ;
	else if login_timeout_check_required (new_state)
	then call LOGIN_TIMEOUT_CHECK ();
	else if login_timeout_check_required (ls_validate_info.state)
	then call LOGIN_TIMEOUT_CHECK_stop ();

	ls_validate_info.state = new_state;

     end Change_state;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* cleanup on unit:						       */
/* 1) Free any allocated login_server requests or responses.	       */
/* 2) Change state to AWAITING_INITIAL_REQUEST.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Cleanup_handler:
     procedure ();

	if ls_request_ptr ^= null ()
	then do;					/* check for "process" requests, which are */
						/*  the only kind we allocate */
	     if ls_request_header.request_type = LS_PROCESS_REQUEST
	     then do;
		if ls_validate_info.process_request_ptr = ls_request_ptr
						/* check to see if we've got another one hidden away */
		then ls_validate_info.process_request_ptr = null ();
						/* not any more we don't */
		free login_server_process_request in (system_area);
	     end;
	end;

	if ls_response_ptr ^= null ()			/* there's a response around, free it */
	then do;
	     if login_server_response_header.message_type = LS_VALIDATE_RESPONSE
	     then free login_server_validate_response in (system_area);
	     else if login_server_response_header.message_type = LS_PROCESS_RESPONSE
	     then free login_server_process_response in (system_area);
	     else if login_server_response_header.message_type = LS_LIST_RESPONSE
	     then free login_server_list_response in (system_area);
	     else if login_server_response_header.message_type = LS_DIAL_RESPONSE
	     then free login_server_dial_response in (system_area);
	     else if login_server_response_header.message_type = LS_OPERATOR_RESPONSE
	     then free login_server_operator_response in (system_area);
	end;

	call Change_state (AWAITING_INITIAL_REQUEST);

     end Cleanup_handler;

Connect_loop_process_request:
     procedure (command_type, process_number, immediate);

/* build a new process request, or (for a "create" request) update an already-allocated one,
   in response to a connect-loop request */

dcl  command_type fixed bin parameter;
dcl  process_number fixed bin parameter;
dcl  immediate bit (1) aligned parameter;

dcl  new_request bit (1) aligned;

	if command_type ^= CREATE_REQ & ls_validate_info.n_disconnected_processes > 1 & process_number = 0
						/* process number omitted, ambiguous */
	then do;
	     call ls_message_$print (ls_message_table_$must_give_process_no);
	     call Enter_connect_loop ();
	     return;
	end;

	ls_validate_info.process_number = process_number;
	if ls_validate_info.process_request_ptr ^= null ()
	then do;					/* use the process request that was filled in from the original login request */
	     new_request = "0"b;
	     ls_request_ptr = ls_validate_info.process_request_ptr;
	     login_server_process_request.command_type = command_type;
	     login_server_process_request.process_number = process_number;
	     login_server_process_request.connection_info = ls_validate_info.user_connection_info;
						/* some of this might have been changed by an intervening terminal_type request */
	end;

	else do;					/* allocate a fresh one */
	     ls_process_request_n_args = 0;
	     ls_process_request_arg_string_length = 0;
	     process_request_size = size (login_server_process_request);
	     allocate login_server_process_request in (system_area) set (ls_request_ptr);
	     new_request = "1"b;

/* initialize values that Fill_in_process_request will need, which otherwise would
   have been supplied on initial command line */

	     auth_specified, brief_specified, brief, warn_specified, force_specified, save_specified, preempt_specified,
		no_start_up, ring_specified = ""b;

	     outer_module, process_overseer, subsystem, home_dir = "";

	     call Fill_in_process_request (command_type);
	end;

	login_server_process_request.immediate = immediate;
	call Send_request_to_initializer (LS_PROCESS_REQUEST, LS_PROCESS_REQUEST_VERSION_1,
	     currentsize (login_server_process_request), new_request, LS_PROCESS_RESPONSE, ls_response_ptr, code);

	call Process_process_response (code);
	return;

     end Connect_loop_process_request;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* COUNT_WAKEUPS:						       */
/* This procedure implements the wakeup loop counter.  Reading of a request  */
/* line, a password, answerback data, etc occurs via a wakeup.  Such wakeups */
/* coming at too fast a rate may indicating garbage transmissions of the     */
/* communication line.  This procedure detects high wakeup frequency and     */
/* hangs up the connection.					       */
/*							       */
/* An excessive rate is defined to be more than COUNT wakeups within	       */
/* INTERVAL seconds, where COUNT and INTERVAL are installation parameters.   */
/* Whenever we get through an interval with fewer than COUNT wakeups,	       */
/* we reset the counter and start a new interval.  Thus, in the most extreme */
/* case, we could get 2 * COUNT -1 wakeups within INTERVAL + DELTA before we */
/* decide to hang up.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Count_wakeups:
     procedure;

dcl  code fixed bin (35);
dcl  current_time fixed bin (71);

	ls_cp_info_ptr = ls_validate_info.cp_info_ptr;
	ip = ls_cp_info.installation_parms_ptr;
	current_time = clock ();
	if ls_validate_info.wakeup_loop.recent_wakeup_time + installation_parms.chn_wakeup_error_loop_seconds * 1000000
	     < current_time
	then do;
	     ls_validate_info.wakeup_loop.recent_wakeup_count = 1;
	     ls_validate_info.wakeup_loop.recent_wakeup_time = current_time;
	end;
	else do;
	     ls_validate_info.wakeup_loop.recent_wakeup_count = ls_validate_info.wakeup_loop.recent_wakeup_count + 1;
	     if ls_validate_info.wakeup_loop.recent_wakeup_count > installation_parms.chn_wakeup_error_loop_count
	     then do;				/* wakeup loop rate exceeded. */
						/* reset the wakeup loop counters */
		ls_validate_info.wakeup_loop.recent_wakeup_time = 0;
		ls_validate_info.wakeup_loop.recent_wakeup_count = 0;
						/* we'll start counting again at next wakeup */
		call iox_$control (iox_$user_io, "abort", null, code);
		call ls_message_$print (ls_message_table_$login_excess_wakeups);
		call Hangup_with_error (error_table_$fatal_error, DONT_TELL_INITIALIZER);
	     end;
	end;
     end Count_wakeups;

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


Enter_connect_loop:
     procedure ();

/* procedure to switch to (or remain in) connect loop: print instructions, set
   new request table if necessary
*/

	if ls_validate_info.n_disconnected_processes > 0
	then call ls_message_$print (ls_message_table_$connect_requests);
	else call ls_message_$print (ls_message_table_$login_requests);

	if ^ls_validate_info.connect_loop
	then do;
	     call ssu_$delete_request_table (sci_ptr, addr (ls_ssu_request_tables_$login_requests), (0));
	     call ssu_$add_request_table (sci_ptr, addr (ls_ssu_request_tables_$connect_requests), 1, code);
	     if code ^= 0
	     then do;
		call ls_report_subr_error_ (code, OUR_NAME,
		     ls_validate_info.cp_info_ptr,
		     "ssu_$add_request_table", TELL_USER, TAKE_DUMP);
		call Hangup_with_error (code, TELL_INITIALIZER);
	     end;

/* make sure "help" works for connect-loop requests */

	     call ssu_$delete_info_dir (sci_ptr, ls_cp_info.login_info_dir, (0));
	     call ssu_$add_info_dir (sci_ptr, ls_cp_info.connect_info_dir, 1, code);
	     if code ^= 0
	     then call ls_report_subr_error_ (code, OUR_NAME,
		ls_validate_info.cp_info_ptr, "ssu_$add_info_dir",
		TELL_USER, TAKE_DUMP);

	     ls_validate_info.connect_loop = "1"b;
	end;

	call Change_state (AWAITING_CONNECT_REQUEST);

	return;
     end Enter_connect_loop;

Fill_in_process_request:
     procedure (command_type);

/* this procedure puts together a login_server_process_request to pass to Send_request_to_initializer.
   The "process" request has already been allocated, and the login args already filled in.
*/

dcl  command_type fixed bin parameter;

	login_server_process_request.handle =
	     ls_validate_info.initializer_handle;
	login_server_process_request.person_id =
	     ls_validate_info.person_id;
	login_server_process_request.project_id =
	     ls_validate_info.project_id;
	login_server_process_request.connection_info =
	     ls_validate_info.user_connection_info;
	login_server_process_request.command_type = command_type;
	login_server_process_request.process_number =
	     ls_validate_info.process_number;
	login_server_process_request.default_io_module =
	     ls_validate_info.connection_desc_ptr ->
	     ls_connection_desc.io_module;

/* in case we're creating a process from login line, copy values set by Parse_login_args */

	login_server_process_request.warn_given = warn_specified;
	login_server_process_request.force_given = force_specified;
	login_server_process_request.save_given = save_specified;
	login_server_process_request.preempt_given = preempt_specified;
	login_server_process_request.brief_given = brief_specified;
	login_server_process_request.init_ring_given = ring_specified;
	login_server_process_request.minimum_ring_given = "1"b;
	login_server_process_request.warn = warn;
	login_server_process_request.force = force;
	login_server_process_request.save_on_disconnect = save;
	login_server_process_request.preempt = preempt;
	login_server_process_request.brief = brief;
	login_server_process_request.initial_ring = ring;
	login_server_process_request.minimum_ring =
	     ls_validate_info.minimum_ring;
	login_server_process_request.no_start_up = no_start_up;
	login_server_process_request.home_dir = home_dir;
	login_server_process_request.outer_module = outer_module;
	login_server_process_request.process_overseer = process_overseer;
	login_server_process_request.subsystem = subsystem;

	if command_type = NEW_PROC_REQ | command_type = DESTROY_REQ
	then login_server_process_request.immediate = immediate;

	return;
     end Fill_in_process_request;

Get_and_process_login_args:
     procedure (TRY_AGAIN);

dcl  TRY_AGAIN label parameter;

dcl  login_line char (100);
dcl  login_line_read fixed bin (21);

	call ls_message_$print (ls_message_table_$login_args);
	call Change_state (AWAITING_LOGIN_ARGS);
	call iox_$get_line (iox_$user_input, addr (login_line), length (login_line), login_line_read, code);
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Reading login arguments.");
	     go to TRY_AGAIN;
	end;
	login_line = rtrim (request_name) || " " || substr (login_line, 1, login_line_read);
	call Change_state (AWAITING_INITIAL_REQUEST);
	call ssu_$execute_line (sci_ptr, addr (login_line), length (rtrim (login_line)), code);
	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code, "Processing login arguments.");
	     go to TRY_AGAIN;
	end;

     end Get_and_process_login_args;

Get_arg_args:
     procedure ();

/* this procedure gets all the user-supplied arguments (i.e., sub-args of the
   "-ag" control arg) and fills them into the login_server_process_request structure.
*/

dcl  current_index fixed bin (21);
dcl  current_entry fixed bin;

	login_server_process_request.n_args = ls_process_request_n_args;
	login_server_process_request.arg_string_length = ls_process_request_arg_string_length;

	if ls_process_request_n_args > 0
	then do;
	     current_index = 1;
	     current_entry = 1;

	     do this_arg = first_arg_arg to number_of_args;
		call cu_$arg_ptr_rel (this_arg, argp, argl, (0), arg_list_ptr);

		login_server_process_request.args (current_entry).start_index = current_index;
		login_server_process_request.args (current_entry).arg_length = argl;
		substr (login_server_process_request.arg_string, current_index, argl) = arg;

		current_index = current_index + argl;
		current_entry = current_entry + 1;
	     end;
	end;

     end Get_arg_args;

Get_initial_password:
     procedure (code);

/* procedure to get current password initially for login or dial request */

dcl  code fixed bin (35) parameter;
dcl  quit_flag bit (1) aligned;
dcl  help_flag bit (1) aligned;


REREAD_PASSWORD:
	call ls_message_$print_nnl (ls_message_table_$password);
	call Get_password (login_server_validate_request.current_password, quit_flag, help_flag, code);

	if code ^= 0
	then return;

	if quit_flag
	then code = error_table_$action_not_performed;

	else if help_flag
	then do;
	     call ls_message_$print (ls_message_table_$help_password);
	     go to REREAD_PASSWORD;
	end;

	else code = 0;
	return;

     end Get_initial_password;

Get_password:
     procedure (result_password, quit_flag, help_flag, code);

dcl  result_password char (8) aligned parameter;
dcl  quit_flag bit (1) aligned parameter;		/* set to "1"b if response is "quit" */
dcl  help_flag bit (1) aligned parameter;		/* set to "1"b if response is "help" or "?" */
dcl  code fixed bin (35) parameter;

dcl  error_message char (64);
dcl  password char (8);

	result_password = "";
	quit_flag, help_flag = "0"b;
	code = 0;

	password = Read_password ();

	if search (rtrim (password), SPACE_SEMICOLON) ^= 0
	then do;
	     password = "";				/* keep possible typo hidden */
	     call ls_message_$print (ls_message_table_$bad_password_format);
	     code = error_table_$action_not_performed;
	end;

	else if password = "help" | password = "HELP" | password = "?"
	then help_flag = "1"b;

	else if password = "quit" | password = "QUIT"
	then do;
	     call ls_message_$print (ls_message_table_$password_quit);
	     quit_flag = "1"b;
	end;

	else do;
	     call check_password_ (password, error_message, code);
	     if code ^= 0				/* check password minimum length and content */
	     then do;
		password = "";
		call ls_message_$print (ls_message_table_$bad_password_check, error_message);
		code = error_table_$action_not_performed;
	     end;
	     else do;
		result_password = scramble_ (password);
		password = "";			/* cover this up as soon as possible */
	     end;
	end;

	return;

     end Get_password;

Get_process_number:
     procedure (immediate_allowed, hold_allowed, process_number, immediate, hold);

/* this procedure gets the (optional) arguments for the connect loop requests:
   process number, and possibly -immediate and/or -hold
*/

dcl  immediate_allowed bit (1) aligned parameter;
dcl  hold_allowed bit (1) aligned parameter;
dcl  process_number fixed bin parameter;
dcl  immediate bit (1) aligned parameter;
dcl  hold bit (1) aligned parameter;

	immediate = "0"b;
	hold = "1"b;
	process_number = 0;
	call ssu_$arg_count (sci_ptr, number_of_args);

	if number_of_args = 0
	then return;

	else if number_of_args > 3
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args);

	else do this_arg = 1 to number_of_args;
	     call ssu_$arg_ptr (sci_ptr, this_arg, argp, argl);

	     if index (arg, HYPHEN) = 1
	     then if (arg = "-immediate" | arg = "-im") & immediate_allowed
		then immediate = "1"b;

		else if (arg = "-hold" | arg = "-hd") & hold_allowed
		then hold = "1"b;

		else if (arg = "-no_hold" | arg = "-nhd") & hold_allowed
		then hold = "0"b;

		else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);

	     else do;
		if arg = ""
		then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "Null value for process number.");
		process_number = cv_dec_check_ (arg, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^a", arg);
	     end;
	end;
	return;

     end Get_process_number;

Get_total_arg_length:
     procedure () returns (fixed bin (21));

/* this procedure returns the total length of the user-supplied arguments (i.e.,
   the sub-arguments of the "-ag" control arg)
*/

dcl  total_length fixed bin (21);

	total_length = 0;
	do this_arg = first_arg_arg to number_of_args;
	     call cu_$arg_ptr_rel (this_arg, argp, argl, (0), arg_list_ptr);
	     total_length = total_length + argl;
	end;

	return (total_length);
     end Get_total_arg_length;

Hangup:
     procedure (tell_initializer);

/* close the connection. the argument indicates whether a disconnect_request has to
   be sent to the Initializer, or whether the latter has already discarded it.
*/

dcl  tell_initializer bit (1) aligned parameter;

	call ls_message_$print (ls_message_table_$hangup);

Hangup_no_message:
     entry (tell_initializer);

	ls_connection_desc_ptr = ls_validate_info.connection_desc_ptr;
	login_service_entries_ptr = ls_connection_desc.service_entries_ptr;

	call login_service_entries
	     .disconnect ((ls_connection_desc.name), ls_connection_desc.connection_handle, ""b, code);

	if ls_validate_info.cp_info_ptr -> ls_cp_info.trace
	then call dsa_log_manager_$trace_message (LS_CALLER_TYPE, OUR_NAME, INFO_LOG_SEVERITY, code, null (), 0, "",
		"Disconnecting ^a", ls_connection_desc.name);

	if tell_initializer
	then do;
	     ls_request_ptr = addr (auto_hangup_request);
	     login_server_disconnect_request.handle = ls_validate_info.initializer_handle;
	     login_server_disconnect_request.process_id = ""b;
	     login_server_disconnect_request.connection_info = ls_validate_info.user_connection_info;

	     call Send_request_to_initializer (LS_DISCONNECT_REQUEST, LS_DISCONNECT_REQUEST_VERSION_1,
		size (auto_hangup_request), "0"b, 0, (null ()), (0));
	end;

	return;

     end Hangup;

Hangup_with_error:
     procedure (code, tell_initializer);

/* Called to wrap up when some unrecoverable disaster occurs */

dcl  code fixed bin (35) parameter;
dcl  tell_initializer bit (1) aligned parameter;

	ls_validate_info.code = code;
	call Hangup (tell_initializer);
	call ssu_$abort_subsystem (sci_ptr);
	return;

     end Hangup_with_error;

List_request:
     procedure ();

/* This procedure sends a "list" request, and displays the information provided in the response */

dcl  auth_case fixed bin;
dcl  (auth_col, chn_col, date_col, id_col, type_col) fixed bin;
dcl  auth_sw bit (1);
dcl  code fixed bin (35);
dcl  (chn_len, date_len, id_len, type_len) fixed bin;
dcl  n_processes fixed bin;
dcl  px fixed bin;

dcl  1 auto_list_request aligned like login_server_list_request;

	ls_request_ptr = addr (auto_list_request);

	login_server_list_request.connection_info =
	     ls_validate_info.user_connection_info;
	login_server_list_request.handle =
	     ls_validate_info.initializer_handle;

	ls_response_ptr = null ();
	on cleanup
	     begin;
	     if ls_response_ptr ^= null ()
	     then free login_server_list_response in (system_area);
	end;

	call Send_request_to_initializer (LS_LIST_REQUEST,
	     LS_LIST_REQUEST_VERSION_1, size (login_server_list_request),
	     "0"b, LS_LIST_RESPONSE, ls_response_ptr, code);

	if code ^= 0
	then call ssu_$print_message (sci_ptr, code);

	else do;
	     n_processes, ls_validate_info.n_disconnected_processes = login_server_list_response.n_processes;

	     if n_processes = 0
	     then call ls_message_$print (ls_message_table_$no_disconnected_processes);

	     else do;
		call ls_message_$print (ls_message_table_$disconnected_processes, n_processes, (n_processes > 1));

/* NOTE: the access_class_range in the user_connection_info substructure in
   the list_response is not accurate and is not to be used.  */

		date_len = date_time_$format_max_length ("system_date_time", "system_zone", "system_lang");
		chn_len = length ("CHANNEL");
		type_len = length ("TERM TYPE");
		id_len = length ("ID");
		auth_sw = FALSE;
		do px = 1 to n_processes;
		     chn_len = max (chn_len, length (rtrim (login_server_list_response.connection_name (px))));
		     type_len = max (type_len, length (rtrim (login_server_list_response.terminal_type (px))));
		     id_len = max (id_len, length (rtrim (login_server_list_response.terminal_id (px))));
		     if login_server_list_response.initial_ring (px) ^= 0
		     then auth_sw = TRUE;
		     if login_server_list_response.authorization (px) ^= SYSTEM_LOW
		     then auth_sw = TRUE;
		end;
		date_col = length ("NN.  D");
		chn_col = date_col + date_len + length (SPSP);
		type_col = chn_col + chn_len + length (SP);
		id_col = type_col + type_len + length (SP);
		if auth_sw
		then auth_col = id_col + id_len + length (SPSP);
		else auth_col = id_col + id_len;

		call ls_message_$print (ls_message_table_$list_proc_header, date_col, chn_col, type_col, id_col,
		     auth_col, auth_sw);

		do px = 1 to n_processes;
		     auth_case = 0;
		     if login_server_list_response.authorization (px) ^= SYSTEM_LOW
		     then auth_case = 2;
		     if login_server_list_response.initial_ring (px) ^= 0
		     then auth_case = auth_case + 1;
		     call ls_message_$print (ls_message_table_$list_process, px, date_col,
			date_time_$format ("system_date_time", login_server_list_response.creation_time (px),
			"system_zone", "system_lang"), chn_col, login_server_list_response.connection_name (px),
			type_col, login_server_list_response.terminal_type (px), id_col,
			login_server_list_response.terminal_id (px), auth_col, auth_case,
			login_server_list_response.initial_ring (px), login_server_list_response.authorization (px))
			;
		end;
	     end;
	end;

	if ls_response_ptr ^= null ()
	then free login_server_list_response in (system_area);
	call Enter_connect_loop ();
	return;

     end List_request;

Login_operator:
     procedure (a_person, a_project, a_virtual_channel, a_code);

/* procedure to send an operator_request and process the response. invoked when
   user enters "dial system" or "login...-operator".
*/

dcl  a_person char (22) parameter;
dcl  a_project char (9) parameter;
dcl  a_virtual_channel char (32) parameter;
dcl  a_code fixed bin (35) parameter;

dcl  1 auto_operator_request aligned like login_server_operator_request;

/* let the user know we're initiating the request -- it might be a while before the operator accepts */

	call ls_message_$print (ls_message_table_$requesting_dial_to_mc);

	ls_request_ptr = addr (auto_operator_request);

	login_server_operator_request.initializer_handle = ls_validate_info.initializer_handle;
	login_server_operator_request.terminate_event_channel =
	     ls_validate_info.connection_desc_ptr -> ls_connection_desc.terminate_event_channel;
	login_server_operator_request.person_id = a_person;
	login_server_operator_request.project_id = a_project;
	login_server_operator_request.virtual_channel = a_virtual_channel;
	login_server_operator_request.connection_info = ls_validate_info.user_connection_info;

	ls_response_ptr = null ();
	on cleanup
	     begin;
	     if ls_response_ptr ^= null ()
	     then free login_server_operator_response in (system_area);
	end;

	call Send_request_to_initializer (LS_OPERATOR_REQUEST, LOGIN_SERVER_OPERATOR_REQUEST_VERSION_1,
	     size (login_server_operator_request), "0"b, LS_OPERATOR_RESPONSE, ls_response_ptr, code);

	if code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, code);
	     if ls_response_ptr ^= null ()
	     then free login_server_operator_response in (system_area);
	     a_code = code;
	     return;
	end;

	if login_server_operator_response.status_code ^= 0
	then do;
	     ls_validate_info.code = ls_convert_as_error_code_ (login_server_operator_response.status_code);
	     if ls_validate_info.code = error_table_$action_not_performed
	     then call ls_message_$print (ls_message_table_$dropped_by_mc,
		     ls_validate_info.user_connection_info.connection_name);
	     else call ls_message_$print_error (ls_validate_info.code);
	     hangup_flag = login_server_operator_response.disconnect;

	     free login_server_operator_response in (system_area);

	     if hangup_flag
	     then do;
		call Hangup (DONT_TELL_INITIALIZER);
		call ssu_$abort_subsystem (sci_ptr);
	     end;

	     a_code = ls_validate_info.code;
	     return;
	end;

/* successfully connected to message coordinator */

	ls_validate_info.code = 0;
	ls_process_info.process_group_id = login_server_operator_response.process_group_id;
	ls_process_info.start_event_channel = login_server_operator_response.event_channel;
	ls_process_info.authorization = ""b;		/* like process_group_id */
	ls_process_info.process_id = login_server_operator_response.process_id;
	ls_process_info.initial_ring = login_server_operator_response.ring;
	ls_process_info.usage_type = LS_MC_USAGE;
	ls_process_info.terminal_type = ls_validate_info.user_connection_info.terminal_type;
	ls_process_info.terminal_id = ls_validate_info.user_connection_info.terminal_id;
	ls_process_info.line_type = ls_validate_info.user_connection_info.line_type;
	ls_process_info.flags.terminal_info_set = "1"b;

	call ls_message_$print (ls_message_table_$dialed_to_mc, ls_validate_info.user_connection_info.connection_name);

	free login_server_operator_response in (system_area);
	a_code = 0;
	return;

     end Login_operator;

Logout:
     procedure (hangup_flag, brief_flag, hangup_code);

/* procedure to terminate the dialogue, and either hang up or restart with the banner,
   depending on the value of hangup_flag */

dcl  hangup_flag bit (1) aligned parameter;
dcl  brief_flag bit (1) aligned parameter;
dcl  hangup_code fixed bin (35) parameter;

	if ^brief_flag
	then call ls_message_$print (ls_message_table_$logout_disconnected, ls_validate_info.person_id,
		ls_validate_info.project_id,
		date_time_$format ("system_date_time", clock (), "system_zone", "system_lang"));

	if hangup_flag
	then do;
	     call Hangup (DONT_TELL_INITIALIZER);
	     ls_validate_info.code = hangup_code;
	     call ssu_$abort_subsystem (sci_ptr);
	end;

/* now reinitialize the validate_info structure */

	if ls_validate_info.process_request_ptr ^= null ()
	then do;
	     free ls_validate_info.process_request_ptr -> login_server_process_request in (system_area);
	     ls_validate_info.process_request_ptr = null ();
	end;

	ls_validate_info.initializer_handle = ""b;
	ls_validate_info.n_disconnected_processes = 0;
	ls_validate_info.process_number = 0;
	ls_validate_info.validation_failures = 0;
	ls_validate_info.person_id = "";
	ls_validate_info.project_id = "";
	ls_validate_info.dial_id = "";

	if ls_validate_info.connect_loop
	then do;
	     call ssu_$delete_request_table (sci_ptr, addr (ls_ssu_request_tables_$connect_requests), (0));
	     call ssu_$add_request_table (sci_ptr, addr (ls_ssu_request_tables_$login_requests), 1, code);
	     if code ^= 0
	     then do;
		call ls_report_subr_error_ (code, OUR_NAME,
		     ls_validate_info.cp_info_ptr,
		     "ssu_$add_request_table", TELL_USER, TAKE_DUMP);
		call Hangup_with_error (code, TELL_INITIALIZER);
	     end;

/* make sure "help" doesn't find connect-loop requests */

	     call ssu_$delete_info_dir (sci_ptr, ls_cp_info.connect_info_dir, (0));
	     call ssu_$add_info_dir (sci_ptr, ls_cp_info.login_info_dir, 1, code);
	     if code ^= 0
	     then call ls_report_subr_error_ (code, OUR_NAME,
		ls_validate_info.cp_info_ptr, "ssu_$add_info_dir",
		TELL_USER, TAKE_DUMP);

	     ls_validate_info.connect_loop = "0"b;
	end;

	call ioa_ ("");				/* just put out newline */
	call Write_greeting_message (DONT_FORCE_MESSAGE);
	call Change_state (AWAITING_INITIAL_REQUEST);

	return;
     end Logout;

Minutes:
     procedure (seconds) returns (fixed decimal (5, 1)) reducible;

dcl  seconds fixed bin;
dcl  minutes fixed decimal (5, 1);
dcl  seconds_dec fixed decimal (7);
dcl  SECONDS_PER_MINUTE fixed decimal (2, 0) int static options (constant) init (60);

	seconds_dec = seconds;
	minutes = divide (seconds_dec, SECONDS_PER_MINUTE, 5, 1);
	return (minutes);
     end Minutes;

Parse_dial_args:
     procedure ();

dcl  keyword char (32);

	call cu_$arg_count_rel (number_of_args, arg_list_ptr, 0);

	if number_of_args < 1 | number_of_args > 6
	then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args,
		"^/Usage: dial dial_qualifier {Person.Project} {-control_args}");

	ls_validate_info.person_id, ls_validate_info.project_id = "";
	user_specified, auth_specified, mask_needed = "0"b;

	call cu_$arg_ptr_rel (1, argp, argl, 0, arg_list_ptr);
	ls_validate_info.dial_id = arg;		/* first arg is always the dial qualifier */

	do this_arg = 2 to number_of_args;
	     call cu_$arg_ptr_rel (this_arg, argp, argl, 0, arg_list_ptr);

	     if index (arg, HYPHEN) ^= 1
	     then do;				/* not control arg. must be Person.Project */
		if this_arg = 2
		then do;				/* User_id must be second arg if given. */
		     period_index = index (arg, DOT);
		     if period_index <= 1 | period_index >= length (arg)
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
			     "Second argument must have the form Person.Project.");
		     else do;
			ls_validate_info.person_id = before (arg, DOT);
			ls_validate_info.project_id = after (arg, DOT);
		     end;
		end;
		else call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
			"^a^/Usage: dial dial_qualifier {Person.Project} {-control_args}");
	     end;
	     else do;

		if arg = "-user"
		then do;
		     call Get_value (dial_person);
		     user_specified = "1"b;
		     if index (dial_person, DOT) = 0
		     then dial_project = "";
		     else do;
			dial_project = after (dial_person, DOT);
			dial_person = before (dial_person, DOT);
		     end;
		end;

		else if arg = "-authorization" | arg = "-auth"
		then do;
		     auth_specified = "1"b;
		     call Get_value (auth_string);
		     call convert_authorization_$from_string (authorization, auth_string, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "^a ^a", keyword, auth_string);
		end;

		else if arg = "-print_off" | arg = "-pf"
		then mask_needed = "0"b;

		else if arg = "-no_print_off" | arg = "-npf"
		then mask_needed = "1"b;

		else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	     end;
	end;

	if auth_specified & ^user_specified
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-auth ^a requires the -user control argument.",
		auth_string);
	return;

Parse_login_args:
     entry ();

/* parse the arguments to the login, enter, enterp requests */

/* we have to use cu_$arg_ptr_rel because one path into here is via the unknown_request
   procedure, in which case ssu_$arg_ptr doesn't work.
*/

dcl  first_control_arg fixed bin;
dcl  auth_string char (256);

	auth_specified, brief_specified, brief, immediate, hold_given, hold_on_destroy, change_password,
	     generate_password, cda, cdp, warn_specified, force_specified, save_specified, preempt_specified,
	     no_start_up, ring_specified, mask_needed, operator = ""b;

	terminal_type, mode_string, terminal_id, outer_module, process_overseer, subsystem, home_dir,
	     virtual_channel_name = "";

	first_arg_arg = number_of_args + 1;		/* initially, to indicate no -arguments */

/* get first arg, may be person ID or Person.Project) */

	call cu_$arg_ptr_rel (1, argp, argl, (0), arg_list_ptr);
	if index (arg, DOT) ^= 0			/* Person.project */
	then do;
	     person_name = before (arg, DOT);
	     project_name = after (arg, DOT);
	     first_control_arg = 2;
	end;

	else do;					/* first arg is person, second might be project */
	     person_name = arg;
	     if number_of_args < 2
	     then do;
		project_name = "";
		return;
	     end;

	     call cu_$arg_ptr_rel (2, argp, argl, (0), arg_list_ptr);
	     if index (arg, HYPHEN) ^= 1
	     then do;
		project_name = arg;
		first_control_arg = 3;
	     end;

	     else do;				/* it's a control arg, process it later */
		project_name = "";
		first_control_arg = 2;
	     end;
	end;

	do this_arg = first_control_arg to number_of_args;
	     call cu_$arg_ptr_rel (this_arg, argp, argl, (0), arg_list_ptr);
	     if index (arg, HYPHEN) ^= 1
	     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg);

	     if arg = "-arguments" | arg = "-ag"
	     then do;
		first_arg_arg = this_arg + 1;		/* we'll process the rest later */
		go to NO_MORE_CONTROL_ARGS;
	     end;

	     else if arg = "-brief" | arg = "-bf"
	     then do;
		brief_specified = "1"b;
		brief = "1"b;
	     end;

	     else if arg = "-long" | arg = "-lg"
	     then do;
		brief_specified = "1"b;
		brief = "0"b;
	     end;

	     else if arg = "-modes" | arg = "-mode" | arg = "-md"
	     then call Get_value (mode_string);

	     else if arg = "-terminal_id" | arg = "-tid"
	     then call Get_value (terminal_id);

	     else if arg = "-terminal_type" | arg = "-ttp"
	     then call Get_value (terminal_type);

	     else if arg = "-print_off" | arg = "-pf"
	     then mask_needed = "0"b;

	     else if arg = "-no_print_off" | arg = "-npf"
	     then mask_needed = "1"b;

	     else if arg = "-warning"
	     then do;
		warn_specified = "1"b;
		warn = "1"b;
	     end;

	     else if arg = "-no_warning" | arg = "-nw"
	     then do;
		warn_specified = "1"b;
		warn = "0"b;
	     end;

	     else if arg = "-force"
	     then do;
		force_specified = "1"b;
		force = "1"b;
	     end;

	     else if arg = "-home_dir" | arg = "-hd"
	     then call Get_value (home_dir);

	     else if arg = "-no_preempt" | arg = "-np"
	     then do;
		preempt_specified = "1"b;
		preempt = "0"b;
	     end;

	     else if arg = "-no_start_up" | arg = "-ns"
	     then no_start_up = "1"b;

	     else if arg = "-outer_module" | arg = "-om"
	     then call Get_value (outer_module);

	     else if arg = "-process_overseer" | arg = "-po"
	     then call Get_value (process_overseer);

	     else if arg = "-subsystem" | arg = "-ss"
	     then call Get_value (subsystem);

	     else if arg = "-ring" | arg = "-rg"
	     then do;
		call Get_numeric_value (ring);
		if ring < 1 | ring > 7
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^d is not a valid ring number.", ring);
		ring_specified = "1"b;
	     end;

	     else if anonymous
	     then go to UNRECOGNIZED_ARG;		/* the rest are not allowed for anonymous users */

	     else if arg = "-authorization" | arg = "-auth"
	     then do;
		auth_specified = "1"b;
		call Get_value (auth_string);
		call convert_authorization_$from_string (authorization, auth_string, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^a ^a", keyword, auth_string);
	     end;

	     else if arg = "-change_password" | arg = "-cpw"
	     then change_password = "1"b;

	     else if arg = "-generate_password" | arg = "-gpw"
	     then generate_password = "1"b;

	     else if arg = "-change_default_auth" | arg = "-cda"
	     then cda = "1"b;

	     else if arg = "-change_default_project" | arg = "-cdp"
	     then cdp = "1"b;

	     else if arg = "-save_on_disconnect" | arg = "-save"
	     then do;
		save_specified = "1"b;
		save = "1"b;
	     end;

	     else if arg = "-no_save_on_disconnect" | arg = "-nosave"
	     then do;
		save_specified = "1"b;
		save = "0"b;
	     end;

	     else if arg = "-immediate" | arg = "-im"
	     then immediate = "1"b;

	     else if arg = "-hold"			/* -hd refers to */
	     then hold_on_destroy, hold_given = "1"b;	/* -home_dir.    */

	     else if arg = "-no_hold"
	     then do;
		hold_on_destroy = "0"b;
		hold_given = "1"b;
	     end;

	     else if arg = "-connect"
	     then do;
		call Check_consistent ();
		call Get_optional_numeric_arg (process_number);
		command_type = CONNECT_REQ;
	     end;

	     else if arg = "-new_proc"
	     then do;
		call Check_consistent ();
		call Get_optional_numeric_arg (process_number);
		command_type = NEW_PROC_REQ;
	     end;

	     else if arg = "-destroy"
	     then do;
		call Check_consistent ();
		call Get_optional_numeric_arg (process_number);
		command_type = DESTROY_REQ;
	     end;

	     else if arg = "-create"
	     then do;
		call Check_consistent ();
		command_type = CREATE_REQ;
	     end;

	     else if arg = "-list"
	     then do;
		call Check_consistent ();
		command_type = LIST_REQ;
	     end;

	     else if arg = "-operator" | arg = "-op"
	     then operator = "1"b;

	     else if arg = "-virtual_channel" | arg = "-vchn" | arg = "-vc"
	     then call Get_value (virtual_channel_name);

	     else
UNRECOGNIZED_ARG:
		call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	end;

NO_MORE_CONTROL_ARGS:
	if immediate & (command_type ^= NEW_PROC_REQ & command_type ^= DESTROY_REQ)
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-immediate without -new_proc or -destroy.");

	if hold_given
	then if command_type ^= DESTROY_REQ
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-hold without -destroy.");
	     else ;
	else if command_type = DESTROY_REQ		/* -hold is default with -destroy. */
	then hold_on_destroy = "1"b;

	if cda & ^auth_specified
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"-change_default_auth requires that -authorization also be used.");

	if cdp & project_name = ""
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"Syntax is ""login Person.NewDefaultProj -change_default_project"".");

	if virtual_channel_name ^= "" & ^operator
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-virtual_channel without -operator.");

	if operator
	then if (auth_specified | warn_specified | force_specified | save_specified | preempt_specified | no_start_up
		| ring_specified | first_arg_arg <= number_of_args | process_overseer ^= "" | subsystem ^= ""
		| home_dir ^= "" | command_type ^= LOGIN_REQ)
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		     "-operator with one or more arguments that only apply to normal user processes.");

	return;

Check_consistent:
	procedure ();

/* (internal to Parse_login_args) checks for inconsistent combinations (such as
   -destroy and -connect) */

	     if command_type ^= LOGIN_REQ
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		     "Only one of -connect, -new_proc, -destroy, -create, or -list may be specified.");
	     return;
	end Check_consistent;


Get_value:
	procedure (value);

/* this procedure (internal to Parse_login_args) gets the string value associated
   with a control argument, and returns it
*/

dcl  value char (*) parameter;
dcl  n_value fixed bin parameter;

dcl  numeric bit (1);

	     numeric = "0"b;
	     go to GET_VALUE_COMMON;

Get_numeric_value:
	entry (n_value);

/* likewise, but value must be a number */

	     numeric = "1"b;

GET_VALUE_COMMON:
	     if this_arg >= number_of_args		/* oops, there isn't one */
	     then call ssu_$abort_line (sci_ptr, error_table_$noarg, "After ^a", arg);

	     else do;
		keyword = arg;
		this_arg = this_arg + 1;

		call cu_$arg_ptr_rel (this_arg, argp, argl, (0), arg_list_ptr);
		if index (arg, HYPHEN) = 1
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "After ^a", keyword);

		else if ^numeric
		then value = arg;

		else do;
CHECK_NUMERIC:
		     if arg = ""
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "Null value for ^a.", keyword);
		     n_value = cv_dec_check_ (arg, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^a ^a", keyword, arg);
		end;
	     end;
	     return;

Get_optional_numeric_arg:
	entry (n_value);

/* this procedure returns a numeric value for a keyword; if there is no value,
   it returns 0
*/

	     n_value = 0;
	     if this_arg >= number_of_args
	     then return;

	     call cu_$arg_ptr_rel (this_arg + 1, argp, argl, (0), arg_list_ptr);
	     if index (arg, HYPHEN) = 1
	     then return;

	     else do;
		this_arg = this_arg + 1;
		go to CHECK_NUMERIC;
	     end;

	end Get_value;

     end Parse_dial_args;

Print_password_mask:
     procedure ();

/* take a constant set of overprinting and overprint it with a random, clock-derived
   string to make deciphering very difficult */

	call ioa_$nnl ("^a^a", CONSTANT_MASK, substr (RANDOM_ALPHABET, mod (clock (), 28), 12) || copy (BS, 12));
						/* 12 backspaces at the end */

	return;
     end Print_password_mask;

Process_process_response:
     procedure (reply_code);

/* this procedure is called when a response comes from a "process" request --
   this is how we determine if the user's intentions were carried out
*/

dcl  reply_code fixed bin (35) parameter;		/* an input parameter indicating the reply code from Send_request_to_initializer */

dcl  logout bit (1) aligned;
dcl  hangup bit (1) aligned;
dcl  process_code fixed bin (35);
dcl  cpu_seconds fixed bin;
dcl  cpu_minutes fixed bin;
dcl  instance fixed bin;
dcl  suffix char (4);
dcl  auth_string char (256);

	if reply_code ^= 0
	then do;					/* got back non-zero code in response to process request */
	     call ssu_$print_message (sci_ptr, reply_code);
	     if ls_response_ptr ^= null ()
	     then free login_server_process_response in (system_area);
	     call Enter_connect_loop ();
	     return;
	end;

	logout = login_server_process_response.logout;
	hangup = login_server_process_response.disconnect;

	if login_server_process_response.status_code ^= 0
	then do;					/* but we didn't succeed */
	     process_code = ls_convert_as_error_code_ (login_server_process_response.status_code);

	     if process_code = as_error_table_$no_such_process_msg
	     then call ls_message_$print (ls_message_table_$no_such_process, ls_validate_info.process_number);

	     else if process_code = as_error_table_$no_connect_aclass
	     then call ls_message_$print (ls_message_table_$no_connect_aclass,
		     (ls_validate_info.n_disconnected_processes > 1), ls_validate_info.process_number);

	     else if login_server_process_response.already_logged_in
	     then call ls_message_$print (ls_message_table_$already_logged_in, ls_validate_info.person_id,
		     ls_validate_info.project_id, login_server_process_response.already_logged_in_info.terminal_type,
		     login_server_process_response.already_logged_in_info.terminal_id);

	     else call ls_message_$print_error (process_code);

	     if logout | hangup
	     then do;
		free login_server_process_response in (system_area);
		if ls_validate_info.process_request_ptr ^= null ()
		then free ls_validate_info.process_request_ptr -> login_server_process_request in (system_area);
		if logout
		then call Logout (hangup, (ls_validate_info.brief), process_code);

		else if hangup
		then do;
		     ls_validate_info.code = process_code;
		     call Hangup (DONT_TELL_INITIALIZER);
		     call ssu_$abort_subsystem (sci_ptr);
		end;
		return;
	     end;

	     if login_server_process_response.n_disconnected_processes > 0
	     then call ls_message_$print (ls_message_table_$disconnected_processes,
		     login_server_process_response.n_disconnected_processes,
		     (login_server_process_response.n_disconnected_processes > 1));
	     ls_validate_info.n_disconnected_processes = login_server_process_response.n_disconnected_processes;
	     free login_server_process_response in (system_area);
	     call Enter_connect_loop ();
	     return;
	end;

/* code is 0, so the initializer did what was requested */

	ls_process_info_ptr = ls_validate_info.process_info_ptr;
	if login_server_process_response.new_handle ^= ""b
	then ls_validate_info.initializer_handle, ls_process_info.initializer_handle =
		login_server_process_response.new_handle;
						/* in case handle is different from */
						/* the one in the validate_response */
	if login_server_process_response.flags.brief
	then ls_validate_info.brief = "1"b;

	if login_server_process_response.destroyed
	then do;
	     call ls_message_$print (ls_message_table_$process_destroyed,
		(ls_validate_info.n_disconnected_processes > 1), ls_validate_info.process_number);

	     cpu_seconds = divide (login_server_process_response.cpu_usage, ONE_MILLION, 17, 0);
	     cpu_minutes = divide (cpu_seconds, 60, 17, 0);
	     cpu_seconds = cpu_seconds - 60 * cpu_minutes;

	     if logout
	     then call ls_message_$print (ls_message_table_$logout, ls_validate_info.person_id,
		     ls_validate_info.project_id,
		     date_time_$format ("system_date_time", clock (), "system_zone", "system_lang"),
		     (cpu_minutes ^= 0), cpu_minutes, cpu_seconds, login_server_process_response.cost);

	     else call ls_message_$print (ls_message_table_$cost_message, (cpu_minutes ^= 0), cpu_minutes, cpu_seconds,
		     login_server_process_response.cost);

	     free login_server_process_response in (system_area);
						/* don't need this any more */

	     if logout
	     then call Logout (^hold_on_destroy, "1"b, error_table_$user_requested_logout);

	     else call Enter_connect_loop ();

	     return;
	end;

/* There's now a process (new or pre-existing) to connect to */

	ls_process_info.process_group_id = login_server_process_response.process_group_id;
	ls_process_info.start_event_channel = login_server_process_response.start_event_channel;
	ls_process_info.process_id = login_server_process_response.process_id;
	ls_process_info.usage_type = LS_LOGIN_USAGE;
	ls_process_info.authorization = login_server_process_response.authorization;
	ls_process_info.initial_ring = login_server_process_response.initial_ring;
	ls_process_info.terminal_type = ls_validate_info.user_connection_info.terminal_type;
	ls_process_info.terminal_id = ls_validate_info.user_connection_info.terminal_id;
	ls_process_info.line_type = ls_validate_info.user_connection_info.line_type;
	ls_process_info.flags.terminal_info_set = "1"b;

/* other fields in ls_process_info were filled in earlier */

	call convert_authorization_$to_string (login_server_process_response.authorization, auth_string, code);
	if auth_string ^= ""
	then call ls_message_$print (ls_message_table_$authorization, auth_string);

	if login_server_process_response.connected
	then call ls_message_$print (ls_message_table_$connected, (ls_validate_info.n_disconnected_processes > 1),
		login_server_process_response.process_number);

	else if login_server_process_response.new_proc
	then call ls_message_$print (ls_message_table_$connected_after_new_proc,
		(ls_validate_info.n_disconnected_processes > 1), ls_validate_info.process_number);

	else do;					/* brand-new process */
	     if login_server_process_response.login_instance > 1
	     then do;
		instance = login_server_process_response.login_instance;
		if instance > 9 & instance < 20
		then suffix = ls_data_$teens_suffix (mod (instance, 10));
		else suffix = ls_data_$suffix (mod (instance, 10));
		call ls_message_$print (ls_message_table_$multiple_login_msg, instance, suffix);
	     end;

	     if ^ls_validate_info.brief
	     then do;

		if login_server_process_response.accounting_message_length > 0
		then call ls_message_$print_error (0, "^a", login_server_process_response.accounting_message);

		call ls_message_$print (ls_message_table_$login, login_server_process_response.anonymous,
		     ls_validate_info.person_id, ls_validate_info.project_id,
		     date_time_$format ("system_date_time", clock (), "system_zone", "system_lang"),
		     ls_validate_info.user_connection_info.terminal_type,
		     ls_validate_info.user_connection_info.terminal_id);
		call ls_message_$print (ls_message_table_$last_login,
		     date_time_$format ("system_date_time", ls_validate_info.previous_login_info.time, "system_zone",
		     "system_lang"), ls_validate_info.previous_login_info.terminal_type,
		     ls_validate_info.previous_login_info.terminal_id);
	     end;
	end;

	free login_server_process_response in (system_area);
	if ls_validate_info.process_request_ptr ^= null ()
	then free ls_validate_info.process_request_ptr -> login_server_process_request in (system_area);

	ls_validate_info.code = 0;			/* all is OK */
	call ssu_$abort_subsystem (sci_ptr);		/* and we're ALL DONE */
	return;

     end Process_process_response;

Process_validate_response:
     procedure (reply_code);
     
dcl  reply_code fixed bin (35) parameter;		/* an input parameter indicating the reply code from Send_request_to_initializer */

	if reply_code ^= 0
	then do;
	     call ssu_$print_message (sci_ptr, reply_code);
	     if ls_response_ptr ^= null ()
	     then free login_server_validate_response in (system_area);
	     go to TRY_AGAIN;
	end;

/* attributes might have been changed even if login refused, so report it now */

	if login_server_validate_response.password_changed
	then call ls_message_$print (ls_message_table_$password_changed);

	if login_server_validate_response.default_auth_changed
	then call ls_message_$print (ls_message_table_$default_auth_changed);

	if login_server_validate_response.default_proj_changed
	then call ls_message_$print (ls_message_table_$default_project_changed);

	if login_server_validate_response.status_code ^= 0
	then do;
	     ls_validate_info.code = ls_convert_as_error_code_ (login_server_validate_response.status_code);
	     call ssu_$print_message (sci_ptr, ls_validate_info.code);
	     hangup_flag = login_server_validate_response.disconnect;

	     if login_server_validate_response.password_expired
	     then call ls_message_$print (ls_message_table_$password_expired,
		     login_server_validate_response.password_interval);

	     if login_server_validate_response.password_unused_too_long
	     then call ls_message_$print (ls_message_table_$password_unused_too_long,
		     login_server_validate_response.password_interval);

	     free login_server_validate_response in (system_area);
	     if hangup_flag
	     then do;
		call Hangup (DONT_TELL_INITIALIZER);
		call ssu_$abort_subsystem (sci_ptr);
	     end;

	     else do;
		ls_validate_info.validation_failures = ls_validate_info.validation_failures + 1;
		ip = ls_cp_info.installation_parms_ptr;
		if ls_validate_info.validation_failures >= installation_parms.part_1.login_tries
		then do;				/* not logged in */
		     call Hangup (DONT_TELL_INITIALIZER);
		     call ssu_$abort_subsystem (sci_ptr);
		end;

		else go to TRY_AGAIN;
	     end;
	end;

/* user is validated now. Tell him if his password has been entered incorrectly */

	if login_server_validate_response.incorrect_passwords > 0
	then call ls_message_$print (ls_message_table_$incorrect_passwords,
		(login_server_validate_response.incorrect_passwords > 1),
		login_server_validate_response.incorrect_passwords,
		date_time_$format ("system_date_time", login_server_validate_response.last_incorrect_password.time,
		"system_zone", "system_lang"), login_server_validate_response.last_incorrect_password.terminal_type,
		login_server_validate_response.last_incorrect_password.terminal_id);
     end Process_validate_response;
	
Read_answerback:
     procedure ();

/* this procedure reads the answerback, and adjusts the terminal type if necessary */

dcl  new_term_type char (32);
dcl  answerback char (64);
dcl  length_read fixed bin (21);

dcl  terminal_id char (4);

dcl  1 auto_terminal_info aligned like terminal_info;

	auto_terminal_info.version = terminal_info_version;
	call iox_$control (iox_$user_io, "terminal_info", addr (auto_terminal_info), code);
	if code ^= 0
	then do;
	     subr_name = "iox_$control terminal_info";
	     call Hangup_no_message (DONT_TELL_INITIALIZER);
	     go to NO_SETUP;
	end;

	ls_validate_info.user_connection_info.terminal_id = auto_terminal_info.id;
	ls_validate_info.user_connection_info.terminal_type = auto_terminal_info.term_type;
	ls_validate_info.user_connection_info.line_type = auto_terminal_info.line_type;

	call iox_$control (iox_$user_io, "wru", null (), code);
	if code = 0
	then do;
	     call iox_$get_chars (iox_$user_input, addr (answerback), length (answerback), length_read, code);
	     if code ^= 0
	     then call Hangup_with_error (code, DONT_TELL_INITIALIZER);
	     call Count_wakeups ();

	     if length_read ^= 0
	     then do;
		call ttt_info_$decode_answerback (substr (answerback, 1, length_read), -1, new_term_type, terminal_id,
		     code);
		if code = 0
		then do;
		     if terminal_id ^= "" & terminal_id ^= auto_terminal_info.id
		     then call Set_term_id (terminal_id);
		     if new_term_type ^= "" & new_term_type ^= auto_terminal_info.term_type
		     then call Set_terminal_type (new_term_type);
		end;
	     end;
	end;
	else code = 0;				/* set main proc's code argument, used at NO_SETUP */
	return;
     end Read_answerback;

Read_password:
     procedure () returns (char (8));

/* read the password, unechoed */

dcl  password_buff char (10);
dcl  length_read fixed bin (21);
dcl  code fixed bin (35);
dcl  send_mask bit (1);

	password_buff = "";
	call Change_state (AWAITING_PASSWORD);
	send_mask = ls_validate_info.mask_needed;

	if ^send_mask
	then do;
	     call iox_$control (iox_$user_io, "printer_off", null (), code);
	     if code ^= 0
	     then send_mask = "1"b;
	end;

	call ioa_ ("");				/* put out newline after printer_off */
	if send_mask
	then call Print_password_mask ();

	call iox_$get_line (iox_$user_input, addr (password_buff), length (password_buff), length_read, code);
	if code ^= 0
	then if code ^= error_table_$long_record
	     then call Hangup_with_error (code, (ls_validate_info.initializer_handle ^= ""b));
	call Count_wakeups ();

	if length_read > 9 | code = error_table_$long_record
	then do;
	     call ls_message_$print (ls_message_table_$password_format_warning);
	     call iox_$control (iox_$user_input, "resetread", null (), (0));
						/* to get rid of any extra characters */
	end;

	if ^send_mask
	then call iox_$control (iox_$user_io, "printer_on", null (), (0));
	return (before (password_buff, NL));

     end Read_password;

Send_request_to_initializer:
     procedure (a_request_type, a_request_version, a_request_size, free_request, response_expected, response_ptr, a_code);

/* procedure to send any of the various login_server requests to the Initializer, using send_ls_request_.
   If the request does not provoke the expected response, it is bad news. */

dcl  a_request_type fixed bin parameter;
dcl  a_request_version char (8) parameter;
dcl  a_request_size fixed bin parameter;
dcl  free_request bit (1) aligned parameter;
dcl  response_expected fixed bin parameter;
dcl  response_ptr pointer parameter;
dcl  a_code fixed bin (35) parameter;

dcl  request_size fixed bin (18);
dcl  message_name fixed bin;
dcl  message_type fixed bin;
dcl  code fixed bin (35);
dcl  reply_code fixed bin (35);

dcl  1 auto_ls_reply_message aligned like ls_reply_message;

dcl  user_message (as_user_message_info.message_length) bit (36) aligned based (ls_response_ptr);

dcl  ls_request (request_size) bit (36) aligned based (ls_request_ptr);


	request_size = a_request_size;

	ls_request_header.request_type = a_request_type;
	ls_request_header.request_version = a_request_version;
	ls_request_header.header_version = LS_REQUEST_HEADER_VERSION_1;
	ls_request_header.reply_event_channel = ls_validate_info.reply_channel;
	ls_request_header.reply_handle = ls_validate_info.server_handle;
	ls_request_header.pad1 = ""b;

	ls_validate_info.expected_response = response_expected;
	call Change_state (AWAITING_INITIALIZER_RESPONSE);

	ls_reply_message_ptr = addr (auto_ls_reply_message);
	call send_ls_request_ (ls_request_ptr, request_size, ls_reply_message_ptr, code);
	if free_request
	then free ls_request in (system_area);

	if code ^= 0
	then do;
	     call ls_report_subr_error_ (code, OUR_NAME,
		ls_validate_info.cp_info_ptr, "send_ls_request_",
		TELL_USER, TAKE_DUMP);
	     call Hangup_with_error (code, DONT_TELL_INITIALIZER);
	end;

	reply_code = ls_convert_as_error_code_ (ls_reply_message.code);

	if reply_code ^= 0
	then if ls_reply_message.request_invalid
	     then do;
		call ls_report_internal_error_ (reply_code, OUR_NAME, ls_validate_info.cp_info_ptr,
		     "Reported in as_reply_message.");
		call Hangup_with_error (reply_code, ls_validate_info.initializer_handle ^= ""b);
	     end;

	if ls_reply_message.response_sent
	then do;
	     as_user_message_info_ptr = addr (auto_as_user_message_info);

	     as_user_message_info.version = AS_USER_MESSAGE_INFO_VERSION_1;
	     string (as_user_message_info.flags) = ""b;
	     as_user_message_info.message_info.message_handle = ls_validate_info.server_handle;

	     call user_message_$read_message (system_areap, as_user_message_info_ptr, code);

	     if code ^= 0
	     then do;
		call ls_report_subr_error_ (code, OUR_NAME,
		     ls_validate_info.cp_info_ptr,
		     "user_message_$read_message", TELL_USER,
		     (code ^= error_table_$no_message));
		call Hangup_with_error (code, ls_validate_info.initializer_handle ^= ""b);
	     end;

	     ls_response_ptr = as_user_message_info.message_ptr;

	     message_type = login_server_response_header.message_type;
	     if message_type = response_expected then;
	     else if message_type = LS_TERMINATION_RESPONSE
	     then do;				/* valid anytime */
		reply_code =
		     ls_convert_as_error_code_ (login_server_termination_response.status_code);
		call Hangup_with_error (reply_code, DONT_TELL_INITIALIZER);
	     end;
	     else if message_type ^= response_expected
	     then do;
		free user_message in (system_area);
		if lbound (LS_RESPONSE_TYPES, 1) <= message_type & message_type <= hbound (LS_RESPONSE_TYPES, 1)
		then message_name = message_type;
		else message_name = LS_UNKNOWN_RESPONSE;
		call ls_report_internal_error_ (0, OUR_NAME, ls_validate_info.cp_info_ptr, "1"b,
		     "Unexpected response from initializer:
  expected ^d (^a response), received ^d (^a response)", response_expected, LS_RESPONSE_TYPES (response_expected),
		     message_type, LS_RESPONSE_TYPES (message_name));
		call Hangup_with_error (error_table_$fatal_error, ls_validate_info.initializer_handle ^= ""b);
	     end;

	     response_ptr = ls_response_ptr;
	     a_code = 0;				/* because relevant information is in response; */
	end;

	else do;					/* no response */
	     response_ptr = null ();
	     a_code = reply_code;
	     if a_code = 0				/* claimed there was nothing wrong */
	     then if response_expected ^= 0		/* but didn't send expected response */
		then do;
		     call ls_report_internal_error_ (0, OUR_NAME, ls_validate_info.cp_info_ptr, "1"b,
			"No response when ^d expected, but code = 0", response_expected);
		     call Hangup_with_error (error_table_$fatal_error, ls_validate_info.initializer_handle ^= ""b);
		end;
	end;

	return;
     end Send_request_to_initializer;

Set_modes:
     procedure (a_mode_string);

dcl  a_mode_string char (*) parameter;

dcl  mode_string char (512);
dcl  returned_modes char (32);
dcl  code fixed bin (35);

	mode_string = a_mode_string;

	call iox_$modes (iox_$user_io, mode_string, returned_modes, code);

	if code ^= 0
	then if code = error_table_$bad_mode
	     then call ls_message_$print_error (code, returned_modes);
	     else call ls_report_subr_error_ (code, OUR_NAME,
		ls_validate_info.cp_info_ptr, "iox_$modes",
		TELL_USER, DONT_TAKE_DUMP);

	return;
     end Set_modes;

Set_term_id:
     procedure (a_terminal_id);

dcl  a_terminal_id char (*);

dcl  code fixed bin (35);

	call iox_$control (iox_$user_io, "store_id", addr (a_terminal_id), code);
	if code ^= 0
	then call ls_message_$print_error (code, "Cannot set terminal id.");
	else ls_validate_info.user_connection_info.terminal_id = a_terminal_id;

	return;
     end Set_term_id;

Set_terminal_type:
     procedure (a_type);

dcl  a_type char (*) parameter;

dcl  terminal_type char (32);

dcl  1 auto_set_term_info aligned like set_term_type_info;

	terminal_type = translate (a_type, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");
						/* make it be all upper case */

	auto_set_term_info.version = stti_version_1;
	auto_set_term_info.name = terminal_type;
	auto_set_term_info.send_initial_string = "1"b;
	auto_set_term_info.set_modes = "1"b;
	auto_set_term_info.ignore_line_type = "0"b;
	auto_set_term_info.mbz = ""b;

	call iox_$control (iox_$user_io, "set_term_type", addr (auto_set_term_info), code);
	if code ^= 0
	then call ls_message_$print_error (code, "Cannot set terminal type.");
	else ls_validate_info.user_connection_info.terminal_type = terminal_type;

	return;
     end Set_terminal_type;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Write_greeting_message:					       */
/* 1) If not in brief mode, then print greeting banner message on terminal.  */
/*    Also, update ls_validate_info.banner_checked_time, since the banner is */
/*    checked by the act of printing.				       */
/*							       */
/* NOTE: This procedure is called by PRINT_BANNER_IF_CHANGED, an alarm call  */
/* handler which is a separate entrypoint into ls_validate_user_.  The only  */
/* variable set by this separate entrypoint is ls_validate_info_ptr, so only */
/* the ls_validate_info structure (and things it points to) can be	       */
/* referenced by this procedure.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Write_greeting_message:
     procedure (force_message);

dcl  force_message bit (1);

dcl  installation_id char (64);
dcl  special_length fixed bin (21);
dcl  special_msg char (special_length) based;
dcl  sysid char (8);

	if ^ls_validate_info.brief | force_message
	then do;
	     ansp = ls_validate_info.cp_info_ptr -> ls_cp_info.answer_table_ptr;

	     if anstbl.special_message ^= ""
	     then do;
		special_length = anstbl.message_lng;
		call ioa_$nnl ("^a", addr (anstbl.special_message) -> special_msg);
	     end;

	     call system_info_$sysid (sysid);
	     call system_info_$installation_id (installation_id);

	     call ls_message_$print (ls_message_table_$greeting_msg, sysid, installation_id,
		ls_validate_info.connection_desc_ptr -> ls_connection_desc.name, float (anstbl.n_units) / 10.0e0,
		float (anstbl.max_units) / 10.0e0, anstbl.n_users,
		date_time_$format ("system_date_time", clock (), "system_zone", "system_lang"));
	     ls_validate_info.banner_checked_time = clock ();
	end;

	return;
     end Write_greeting_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

%include answer_table;

%include as_user_message_info;

%include cp_character_types;

%include dsa_log_constants;

%include installation_parms;

dcl  ip pointer;

%include login_server_messages;

%include login_service_entries;

%include ls_connection_desc;

%include ls_cp_info;

%include ls_process_info;

%include ls_usage_types;

%include ls_validate_info;

%include set_term_type_info;

%include ssu_prompt_modes;

%include ssu_rp_options;

%include terminal_info;

%include timer_manager_constants;

%include user_table_header;

     end ls_validate_user_;




		    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
