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 ("^ ^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