



		    ARPA_links_.pl1                 01/09/80  1047.6rew 01/09/80  0915.1      215604



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

ARPA_links_:
     procedure ();

	return;					/* not an entry */

/* User commands for accepting, rejecting, and responding to ARPA Network RSEXEC links.  This procedure
   is a combination of the old accept_rsexec_links and rsexec_respond commands.
   */

/* Initial version by Gerard J. Rudisin */
/* Complete rewrite and reorganization:  10 March 1978 by G. Palter */


dcl  ARPAnet_msgs_name character (32);
dcl  dirname character (168);
dcl  project_id character (28);
dcl  person_id character (28);

dcl  ARPAseg_ptr pointer static initial (null ());	/* locates communications segment */
dcl  link_subscript_array (5) fixed binary (35) static;	/* for communication via ipc_ */
dcl  have_links bit (1) aligned static initial ("0"b);	/* control setup of alarm processor */

dcl  msg_prefix character (32) varying static initial ("ARPA: "); /* prefix - user settable */

dcl 1 char_buffer (5) aligned static,			/* buffer containing line being built for each link */
    2 num_bytes fixed binary (24),
    2 workspace aligned,
      3 byte (0: 255) bit (8) unaligned;

dcl 1 event_info aligned based,			/* information concerning this wakeup */
    2 channel_id fixed binary (71),
    2 message fixed binary (71),
    2 sender bit (36),
    2 origin,
      3 dev_signal bit (18) unaligned,
      3 ring bit (18) unaligned,
    2 data_ptr pointer;

dcl 1 read_status aligned,				/* indicates presence or lack of read-ahead */
    2 read_channel fixed binary (71),
    2 input_available bit (1) unaligned,
    2 pad bit (35) unaligned;

dcl 1 query_info aligned,				/* for automatic answer mode */
    2 version fixed binary initial (2),
    2 yes bit (1) unaligned initial ("1"b),
    2 suppress_name_switch bit (1) unaligned initial ("0"b),
    2 code fixed binary (35) initial (0),
    2 query_code fixed binary (35) initial (0);

dcl  RSEXEC_Servers (2) character (32) static options (constant)
     initial ("CSR_Print.*.*", "Network_Server.*.*");

dcl 1 segment_acl aligned,
    2 name character (32),
    2 modes bit (36) initial ("101"b),
    2 mbz bit (36) initial ("0"b),
    2 status fixed binary (35);

dcl  BreakMsg character (15) static options (constant) initial ("Breaking link.
");

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  answer character (32) varying;

dcl  buffer_byte bit (8);
dcl  NewLine bit (8) static options (constant) initial ("00001010"b);
dcl  message_bit bit (72);
dcl  message_pointer pointer;
dcl  temp_ptr pointer;
dcl  based_number fixed binary (35) based;
dcl  wakeup_pointer pointer;
dcl  iocb_ptr pointer;
dcl  unique_name character (15);

dcl  uid_picture picture "zzzzzzzzzzz9";
dcl  pin_picture picture "zzzzzzzzzzz9";
dcl  attach_description character (128);

dcl  code fixed binary (35);
dcl (i, j) fixed binary;
dcl  num_chars fixed binary (24);
dcl  next_char fixed binary (24);
dcl  link_id_no fixed binary;
dcl  temp_link_id fixed binary (35);

dcl  received_string character (256);
dcl  host_name character (32);

dcl (error_table_$bad_conversion,
     error_table_$bad_index,
     error_table_$badopt,
     error_table_$lock_wait_time_exceeded,
     error_table_$wrong_no_of_args)
     fixed binary (35) external;

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

dcl  Eight fixed binary (35) static options (constant) initial (8);

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cv_dec_check_ entry (character (*), fixed binary) returns (fixed binary (35));
dcl  get_process_id_ entry () returns (bit (36));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$add_acl_entries entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
dcl  hcs_$initiate entry (character (*), character (*), character (*), fixed binary (1),
     fixed binary (2), pointer, fixed binary (35));
dcl  hcs_$make_seg entry (character (*), character (*), character (*), fixed binary (5), pointer, fixed binary (35));
dcl  host_id_$symbol entry (fixed binary (8), character (*), fixed binary (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$find_iocb entry (character (*), pointer, fixed binary (35));
dcl  iox_$attach_iocb entry (pointer, character (*), fixed binary (35));
dcl  iox_$destroy_iocb entry (pointer, fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$get_chars entry (pointer, pointer, fixed binary (24), fixed binary (24), fixed binary (35));
dcl  iox_$get_line entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$decl_ev_call_chn entry (fixed binary (71), entry, pointer, fixed binary, fixed binary (35));
dcl  ipc_$decl_ev_wait_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  net_convert_size_$ascii_8_to_9 entry (pointer, pointer, fixed binary (24), fixed binary (24), fixed binary (24),
     pointer, fixed binary (24), fixed binary (24), fixed binary (24), fixed binary (35));
dcl  rsexec_ascii_$send_line entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  set_lock_$lock entry (bit (36) aligned, fixed binary, fixed binary (35));
dcl  set_lock_$unlock entry (bit (36) aligned, fixed binary (35));
dcl  timer_manager_$alarm_call entry (fixed binary (71), bit (2), entry);
dcl  timer_manager_$reset_alarm_call entry (entry);
dcl  unique_chars_ entry (bit (*)) returns (character (15));
dcl  user_info_ entry options (variable);

dcl (addr, binary, hbound, lbound, length, maxlength, mod, null, rtrim, substr, unspec) builtin;


%include rsexec_ult_dcls;


accept_rsexec_links:
arl:
	entry () options (variable);

/* The accept_rsexec_links command initiates the segment Person_id.ARPAnet_msgs for accepting
   Network links.  If the segment does not exist, it is created.  An event-call channel is
   established to accept links from the RSEXEC server process.
   */

	call cu_$arg_count (i);

	do j = 1 to i;

	     call cu_$arg_ptr (j, argument_ptr, argument_lth, code);

	     if substr (argument, 1, 1) = "-"
	     then do;
		if argument = "-prefix"
		then do;
		     j = j + 1;
		     call cu_$arg_ptr (j, argument_ptr, argument_lth, code);
		     if code ^= 0 then do;
			call com_err_ (code, "accept_rsexec_links", "-prefix requires a prefix string.");
			return;
		     end;
		     if argument_lth > maxlength (msg_prefix)
		     then do;
			call com_err_ (0, "accept_rsexec_links", "Prefix must be ^d characters or less.", maxlength (msg_prefix));
			return;
		     end;
		     msg_prefix = argument;
		end;

		else do;
		     call com_err_ (error_table_$badopt, "accept_rsexec_links", """^a""", argument);
		     return;
		end;
	     end;

	     else do;
		call com_err_ (error_table_$wrong_no_of_args, "accept_rsexec_links",
		     "^/     Usage:  accept_rsexec_links {-preifx string}");
		return;
	     end;
	end;


	call user_info_ (person_id, project_id);
	dirname = ">udd>" || rtrim (project_id) || ">" || rtrim (person_id);
	ARPAnet_msgs_name = rtrim (person_id) || ".ARPAnet_msgs";

	call hcs_$initiate (dirname, ARPAnet_msgs_name, "", 0b, 01b, ARPAseg_ptr, code);

	if ARPAseg_ptr = null ()
	then do;					/* the segment does not exist */
	     call hcs_$make_seg (dirname, ARPAnet_msgs_name, "", 01010b, ARPAseg_ptr, code);
						/* try to create it */
	     if ARPAseg_ptr = null () then do;
		call com_err_ (code, "accept_rsexec_links", "Creating ^a>^a.", dirname, ARPAnet_msgs_name);
		return;
	     end;

	     call com_err_ (0, "accept_rsexec_links", "Creating ^a>^a.", dirname, ARPAnet_msgs_name);

	     do i = 1 to hbound (RSEXEC_Servers, 1);	/* provide the possible servers with access */
		segment_acl.name = RSEXEC_Servers (i);
		call hcs_$add_acl_entries (dirname, ARPAnet_msgs_name, addr (segment_acl), 1, code);
		if code ^= 0 then do;
		     call com_err_ (segment_acl.status, "accept_rsexec_links", "Adding access for ^a to ^a>^a.",
			RSEXEC_Servers (i), dirname, ARPAnet_msgs_name);
		end;
	     end;
	end;

	users_link_table.lock = "0"b;			/* initialize segment for new process */
	users_link_table.number_of_links = 0;
	users_link_table.last_source_identifier = 0;
	users_link_table.linkees_process_id = get_process_id_ ();

	do i = lbound (users_link_table.links, 1) to hbound (users_link_table.links, 1);
	     link_subscript_array (i) = i;
	     users_link_table.links (i).listener_id,
		users_link_table.links (i).foreign_host_number,
		users_link_table.links (i).link_identifier = 0;
	     char_buffer (i).num_bytes = 0;
	end;

	call ipc_$create_ev_chn (users_link_table.link_notice_channel, code); /* set up event call handler */
	if code ^= 0 then do;
	     call com_err_ (code, "accept_rsexec_links", "Creating event channel.");
	     return;
	end;

	call ipc_$decl_ev_call_chn (users_link_table.link_notice_channel, link_request_processor,
	     ARPAseg_ptr, 1, code);
	if code ^= 0 then call com_err_ (code, "accept_rsexec_links", "Making event call channel.");

	return;



reject_rsexec_links:
rrl:
	entry () options (variable);

	call cu_$arg_count (i);
	if i ^= 0 then do;
	     call com_err_ (error_table_$wrong_no_of_args, "reject_rsexec_links", "No arguments permitted.");
	     return;
	end;


/* The reject_rsexec_links command terminates any RSEXEC links currently in progress and
   prevents further links.  It is similar to the defer_messages command, but is more drastic.
   */

	if ARPAseg_ptr = null () then do;
	     call com_err_ (0, "reject_rsexec_links", "You are not currently accepting Network links.");
	     return;
	end;


	call set_lock_$lock (users_link_table.lock, 5, (0)); /* stop others from playing */

	do i = lbound (users_link_table.links, 1) to hbound (users_link_table.links, 1);

	     if links (i).link_identifier ^= 0 then do;	/* break this link */

		call com_err_ (0, "reject_rsexec_links", "Breaking link ^d.", links (i).link_identifier);

		call rsexec_ascii_$send_line (links (i).send_socket.send_iocb_ptr, addr (BreakMsg), length (BreakMsg), (0));

		call destroy (links (i).receive_socket.receive_iocb_ptr);
		call destroy (links (i).send_socket.send_iocb_ptr);

		links (i).listener_id,
		     links (i).link_identifier,
		     links (i).foreign_host_number = 0;
	     end;
	end;


	call ipc_$delete_ev_chn (users_link_table.link_notice_channel, (0));
	users_link_table.link_notice_channel = 0;	/* stop links */
	users_link_table.linkees_process_id = "0"b;

	if have_links then do;
	     call timer_manager_$reset_alarm_call (alarm_processor);
	     have_links = "0"b;
	end;

	call set_lock_$unlock (users_link_table.lock, (0));

	return;



link_request_processor:
	entry (wakeup_pointer);

/* This entry is called by a wakeup from the rsexec_server_ when a valid LINK request is received.
   The message field of the wakeup contains the server's network userid and the link_id_no, which
   is the subscript of the new link in the users_link_table.links array.  This entry uses
   the net_data_transfer_ switch with passoffs to accept the sockets from the server which
   are to be the switches for the ASCII data.
   */


	message_bit = unspec (wakeup_pointer -> event_info.message);
	link_id_no = binary (substr (message_bit, 1, 18), 18);


/* Setup receive connection */

	unique_name = unique_chars_ (""b);
	call iox_$find_iocb ("ARPA_receive_." || unique_name, iocb_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, "ARPA_links_", "Setting up receive switch for ARPA Network link.");
	     go to restart_userio;
	end;

	users_link_table.links (link_id_no).receive_socket.receive_iocb_ptr = iocb_ptr;

	call iox_$close (iocb_ptr, (0));
	call iox_$detach_iocb (iocb_ptr, (0));

	uid_picture = binary (users_link_table.servers_network_uid, 24);

	pin_picture = users_link_table.links (link_id_no).receive_socket.receive_pin_no;
	attach_description = "net_data_transfer_ -connect passoff -userid " || uid_picture || " -local_pin " || pin_picture;

	call iox_$attach_iocb (iocb_ptr, attach_description, code);
	if code ^= 0 then do;
no_receive:
	     call com_err_ (code, "ARPA_links_", "Setting up receive switch for ARPA Network link.");
	     call destroy (iocb_ptr);
	     go to restart_userio;
	end;

	call iox_$control (iocb_ptr, "setsize", addr (Eight), code);
	call iox_$open (iocb_ptr, 1, "0"b, code);
	if code ^= 0 then go to no_receive;


/* Setup the send connection */

	call iox_$find_iocb ("ARPA_send_." || unique_name, iocb_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, "ARPA_links_", "Setting up send switch for ARPA Network link.");
	     go to restart_userio;
	end;

	users_link_table.links (link_id_no).send_socket.send_iocb_ptr = iocb_ptr;

	call iox_$close (iocb_ptr, (0));
	call iox_$detach_iocb (iocb_ptr, (0));

	i = users_link_table.links (link_id_no).send_socket.send_pin_no;
	pin_picture = i - mod (i, 2);

	attach_description = "net_data_transfer_ -connect passoff -userid " || uid_picture || " -local_pin " || pin_picture;

	call iox_$attach_iocb (iocb_ptr, attach_description, code);
	if code ^= 0 then do;
no_send:
	     call com_err_ (code, "ARPA_links_", "Setting up send switch for ARPA Network link.");
	     call destroy (users_link_table.links (link_id_no).receive_socket.receive_iocb_ptr);
	     call destroy (iocb_ptr);
	     go to restart_userio;
	end;

	call iox_$control (iocb_ptr, "setsize", addr (Eight), code);
	call iox_$open (iocb_ptr, 2, "0"b, code);
	if code ^= 0 then go to no_send;


/* Inform user of the new link and start reading from it */

	iocb_ptr = links (link_id_no).receive_socket.receive_iocb_ptr;
	temp_link_id = users_link_table.links (link_id_no).link_identifier;

	call host_id_$symbol (users_link_table.links (link_id_no).foreign_host_number, host_name, (0));

	call ioa_$ioa_switch (iox_$user_io, msg_prefix || "Network link from ^a:  link identifier is ^d.",
	     host_name, temp_link_id);

	if ^ have_links then do;			/* first link, start alarm processor */
	     have_links = "1"b;
	     call timer_manager_$alarm_call (30, "11"b, alarm_processor);
	end;

	system_area_ptr = get_system_free_area_ ();
	allocate event_info in (system_area) set (temp_ptr);
	temp_ptr -> event_info.data_ptr = addr (link_subscript_array (link_id_no));

	call input_line_processor (temp_ptr);

	free temp_ptr -> event_info in (system_area);

	call command_query_ (addr (query_info), answer, "ARPA_links_",
	     "Do you you wish to respond to this link immediately?");
	if answer = "yes"
	then call response_loop ("ARPA_links_", links (link_id_no).send_socket.send_iocb_ptr);


restart_userio:
	call iox_$control (iox_$user_io, "start", null (), (0));

	return;



input_line_processor:
	entry (message_pointer);

/* This entry processes I/O over the switches setup previously for the link.  It is initially invoked
   after the switches are setup.  It is then subsequently called via an event call channel as data becomes
   available over the link.
   */


	temp_ptr = message_pointer -> event_info.data_ptr;
	link_id_no = temp_ptr -> based_number;
	iocb_ptr = users_link_table.links (link_id_no).receive_socket.receive_iocb_ptr;
	temp_link_id = users_link_table.links (link_id_no).link_identifier;

	do while ("1"b);
	     do buffer_byte = ""b repeat (buffer_byte) while (buffer_byte ^= NewLine);
		call iox_$control (iocb_ptr, "get_chars_status", addr (read_status), code);
		if code ^= 0
		then if code = error_table_$bad_index
		     then do;			/* connection was broken */
			call com_err_ (0, "ARPA_links_", "Connection has been broken.  Link ^d.", temp_link_id);
			go to cleanup;
		     end;
		     else do;
			call com_err_ (code, "ARPA_links_", "Reading status.  Link ^d broken.", temp_link_id);
			go to cleanup;
		     end;

		if ^ read_status.input_available
		then do;				/* no input now: set up event call channel */
		     call ipc_$decl_ev_call_chn (read_status.read_channel, input_line_processor,
			addr (link_subscript_array (link_id_no)), 1, code);
		     if code ^= 0
		     then do;
			call com_err_ (code, "ARPA_links_", "Link ^d broken.", temp_link_id);
			go to cleanup;
		     end;

		     call iox_$control (iox_$user_io, "start", null (), (0));
		     return;
		end;

		next_char = char_buffer (link_id_no).num_bytes;
		call iox_$get_chars (iocb_ptr, addr (buffer_byte), 1, (0), code);
		if code ^= 0
		then do;
		     call com_err_ (code, "ARPA_links_", "Reading from link.  Link ^d broken.", temp_link_id);
		     go to cleanup;
		end;

		char_buffer (link_id_no).workspace.byte (next_char) = buffer_byte;
		char_buffer (link_id_no).num_bytes = next_char + 1;
	     end;

	     call net_convert_size_$ascii_8_to_9 (null (),
		addr (char_buffer (link_id_no).workspace.byte (0)), 0, next_char + 1, (0),
		addr (received_string), 0, length (received_string), num_chars, (0));

	     call set_lock_$lock (users_link_table.lock, 5, code);
	     if code = error_table_$lock_wait_time_exceeded
	     then do;				/* multiple links happening */
		call com_err_ (0, "ARPA_links_", "Internal error in program.  Link ^d broken.", temp_link_id);
		go to cleanup;
	     end;
	     if temp_link_id = users_link_table.last_source_identifier then do;
		call set_lock_$unlock (users_link_table.lock, (0));
		call ioa_$ioa_switch (iox_$user_io, msg_prefix || ":= ^a", substr (received_string, 1, num_chars-1));
	     end;
	     else do;
		users_link_table.last_source_identifier = temp_link_id;
		call set_lock_$unlock (users_link_table.lock, (0));
		call ioa_$ioa_switch (iox_$user_io, msg_prefix || "From link ^d:  ^a", temp_link_id,
		     substr (received_string, 1, num_chars-1));
	     end;

	     char_buffer (link_id_no).num_bytes = 0;
	end;

cleanup:
	call destroy (users_link_table.links (link_id_no).receive_socket.receive_iocb_ptr);
	call destroy (users_link_table.links (link_id_no).send_socket.send_iocb_ptr);

	call set_lock_$lock (users_link_table.lock, 5, (0));
	links (link_id_no).listener_id,
	     links (link_id_no).link_identifier,
	     links (link_id_no).foreign_host_number = 0;
	users_link_table.number_of_links = users_link_table.number_of_links - 1;
	if users_link_table.number_of_links = 0 then do;	/* flushed last link */
	     call timer_manager_$reset_alarm_call (alarm_processor);
	     have_links = "0"b;
	end;
	call set_lock_$unlock (users_link_table.lock, (0));

	call ipc_$decl_ev_wait_chn (read_status.read_channel, (0));

	call iox_$control (iox_$user_io, "start", null (), (0));

	return;



alarm_processor:
	entry ();

/* This entry is invoked every 30 seconds while links are enabled to check the status of
   the links.  It will flush any links which have been terminated.  If all links are
   terminated, it will not reschedule itself.
   */

	call set_lock_$lock (users_link_table.lock, 5, (0)); /* need to prevent access to database */

	if users_link_table.number_of_links ^= 0 then do;

	     do i = lbound (users_link_table.links, 1) to hbound (users_link_table.links, 1);

		if links (i).link_identifier ^= 0 then do; /* this slot claims to be active */
		     call iox_$control (links (i).receive_socket.receive_iocb_ptr,
			"get_chars_status", addr (read_status), code);

		     if code ^= 0 then do;		/* link is gone */
			if code = error_table_$bad_index
			then call com_err_ (0, "ARPA_links_",
			     "Connection has been broken.  Link ^d.", links (i).link_identifier);
			else call com_err_ (code, "Reading status.  Link ^d broken.", links (i).link_identifier);

			call destroy (links (i).receive_socket.receive_iocb_ptr); /* break it */
			call destroy (links (i).send_socket.send_iocb_ptr);
			links (i).listener_id,
			     links (i).foreign_host_number,
			     links (i).link_identifier = 0;

			users_link_table.number_of_links = users_link_table.number_of_links - 1;
		     end;
		end;
	     end;
	end;


	if users_link_table.number_of_links ^= 0
	then call timer_manager_$alarm_call (30, "11"b, alarm_processor); /* reschedule */
	else have_links = "0"b;

	call set_lock_$unlock (users_link_table.lock, (0));

	call iox_$control (iox_$user_io, "start", null (), (0));

	return;



rsexec_respond:
	entry () options (variable);

/* The rsexec_respond command permits a user to reply to an arbitrary ARPA Network link to which
   they are a party.
   */


	call cu_$arg_count (i);
	if i ^= 1 then do;
	     call com_err_ (error_table_$wrong_no_of_args, "rsexec_respond",
		"^/     Usage:  rsexec_respond link-identifier");
	     return;
	end;

	call cu_$arg_ptr (1, argument_ptr, argument_lth, code);

	link_id_no = cv_dec_check_ (argument, i);
	if i ^= 0 then do;
	     call com_err_ (error_table_$bad_conversion, "rsexec_respond",
		"Link identifier must be numeric.  ^a", argument);
	     return;
	end;

	if ARPAseg_ptr = null () then do;
	     call com_err_ (0, "rsexec_respond", "You have not accepted ARPA Network links.");
	     return;
	end;

	call set_lock_$lock (users_link_table.lock, 5, code);
	if code = error_table_$lock_wait_time_exceeded then do;
	     call com_err_ (code, "rsexec_respond", "Try again.");
	     return;
	end;

	do i = lbound (users_link_table.links, 1) to hbound (users_link_table.links, 1);
	     if users_link_table.links (i).link_identifier = link_id_no
	     then go to have_link;
	end;

	call set_lock_$unlock (users_link_table.lock, (0));
	call com_err_ (0, "rsexec_respond", "You are not a party to link ^d.", link_id_no);
	return;


have_link:
	call set_lock_$unlock (users_link_table.lock, (0));

	call response_loop ("rsexec_respond", links (i).send_socket.send_iocb_ptr);

	return;



response_loop:
	procedure (command, iocb_ptr);

/* This internal procedure is the response loop for both the rsexec_respond command and
   the automatic response mode in link_request_processor.
   */

dcl  command character (*);
dcl  iocb_ptr pointer;

dcl 1 line aligned,					/* an input line */
    2 curlth fixed binary (21),
    2 text character (512);
dcl  line_varying character (512) varying based (addr (line));

dcl  EndResponse character (2) static options (constant) initial (".
");


	     line.curlth = 0;			/* initially no line */

	     call ioa_$ioa_switch (iox_$user_output, "Input:");


	     do while (line_varying ^= EndResponse);

		call iox_$get_line (iox_$user_input, addr (line.text), length (line.text), line.curlth, (0));

		if line_varying ^= EndResponse then do;
		     call rsexec_ascii_$send_line (iocb_ptr, addr (line.text), line.curlth, code);
		     if code ^= 0 then do;
			if code = error_table_$bad_index
			then call com_err_ (0, command, "Connection has been broken.");
			else call com_err_ (code, command, "Transmitting response line.");
			return;
		     end;
		end;
	     end;

	     return;

	end response_loop;



destroy:
	procedure (iocb_ptr);

/* Internal procedure to destory an I/O switch */

dcl  iocb_ptr pointer;


	     call iox_$close (iocb_ptr, (0));
	     call iox_$detach_iocb (iocb_ptr, (0));
	     call iox_$destroy_iocb (iocb_ptr, (0));

	     return;

	end destroy;


     end ARPA_links_;




		    absentee_rsexec.pl1             01/09/80  1047.6rew 01/09/80  0922.2      121905



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

absentee_rsexec:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (num_args fixed binary (17),
          err_code fixed binary (35),
          date_string character (24))
               automatic;

     declare
          abort_command variable entry options (variable) initial (abort_command_invocation)
               automatic;

          /* * * * * INTERNAL STATIC DECLARATIONS  * * * * */

     declare
         (remembered_shutdown_time fixed binary (71) initial (0),
          check_interval fixed binary (17) initial (600))
               internal static;

          /* * * * * TEXT SECTION REFERENCES * * * * * * * */

     declare
         (MILLION fixed binary (20) initial (1000000),
          PROG character (32) initial ("absentee_rsexec"),
          HOME_DIR character (64) varying initial (">udd>CompNet>Transfer"))
               internal static options (constant);

          /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */

          /* * * * * EXTERNAL STATIC DECLARATIONS  * * * * */

     declare
          1 rsexec_info$ aligned external static,
             2 server_lock_id bit (36) aligned,
             2 server_process_id bit (36) aligned,
             2 server_group_id character (32) unaligned,
             2 listening_channel fixed binary (71),
             2 service_start_time fixed binary (71),
             2 scheduled_stop_time fixed binary (71);

     declare
         (error_table_$badopt,
          error_table_$invalid_lock_reset,
          error_table_$noarg,
          error_table_$segknown)
               fixed binary (35) external static;

          /* * * * * ENTRY & PROCEDURE DECLARATIONS  * * * */

     declare
          clock_ constant entry () returns (fixed bin (71)),
          com_err_ constant entry options (variable),
          cu_$arg_count constant entry () returns (fixed bin (17)),
          cu_$arg_list_ptr constant entry () returns (ptr),
          cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr),
          cu_$gen_call constant entry (entry, ptr),
          date_time_ constant entry (fixed bin (71), char (*)),
          enter_abs_request constant entry options (variable),
          get_group_id_ constant entry () returns (char (32)),
          get_lock_id_ constant entry () returns (bit (36) aligned),
          get_process_id_ constant entry () returns (bit (36) aligned),
          hcs_$initiate constant entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2),
                    ptr, fixed bin (35)),
          hcs_$wakeup constant entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)),
          ioa_ constant entry options (variable),
          ipc_$create_ev_chn constant entry (fixed bin (71), fixed bin (35)),
          ipc_$decl_ev_call_chn constant entry (fixed bin (71), entry, ptr, fixed bin (17), fixed bin (35)),
          logout constant entry options (variable),
          run_rsexec_server constant entry options (variable),
          set_lock_$lock constant entry (bit (36) aligned, fixed bin (17), fixed bin (35)),
          set_lock_$unlock constant entry (bit (36) aligned, fixed bin (35)),
          system_info_$next_shutdown constant entry (fixed bin (71), char (*), fixed bin (71)),
          timer_manager_$alarm_call constant entry (fixed bin (71), bit (2), entry),
          timer_manager_$reset_alarm_call constant entry (entry);

     declare
          (divide, null)
               builtin;

          /* * * * * STACK REFERENCES  * * * * * * * * * * */

     declare
          error condition,
          cleanup condition;

          /* * * * * INCLUDE FILES * * * * * * * * * * * * */

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

          err_code = 0;

          num_args = cu_$arg_count ();

          call process_options (cu_$arg_list_ptr ());

          on cleanup
               call cleanup_after_command ();

          call initiate_stored_data ();

          call set_lock_$lock (rsexec_info$.server_lock_id, 5, err_code);
          if (err_code ^= 0) & (err_code ^= error_table_$invalid_lock_reset)
          then call abort_command (err_code, PROG, "Setting RSEXEC service lock.");

          rsexec_info$.server_process_id = get_process_id_ ();
          rsexec_info$.server_group_id = get_group_id_ ();

          call ipc_$create_ev_chn (rsexec_info$.listening_channel, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Creating event channel.");

          call ipc_$decl_ev_call_chn (rsexec_info$.listening_channel, recheck_shutdown_time, null (), 1, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Setting up event call channel.");

          call enter_delayed_abs_request ("1 day");

          rsexec_info$.service_start_time = clock_ ();

          call date_time_ (rsexec_info$.service_start_time, date_string);
          call ioa_ ("RSEXEC Service started at ^a", date_string);

          call perform_function ();

          call run_rsexec_server ();

          call cleanup_after_command ();

return_to_caller:
          return;

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

recheck_shutdown_time:
          entry ();

          if rsexec_info$.server_lock_id ^= get_lock_id_ ()
          then do;
               call ioa_ ("Service is no longer assigned to this process.");
               call date_time_ (clock_ (), date_string);
               call ioa_ ("Logging out at ^a", date_string);

               call logout ();
               return;
               end;

          call perform_function ();

          return;

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

shutdown_and_reschedule:
          entry ();

          call ioa_ (clock_ (), date_string);
          call ioa_ ("Shutdown is close.  Logging out at ^a.", date_string);

          call enter_delayed_abs_request ("5 minutes");

          call set_lock_$unlock (rsexec_info$.server_lock_id, (0));

          call logout ();

          return;

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

schedule_rsexec_service:
          entry ();

          call enter_delayed_abs_request ("5 seconds");

          return;

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

shutdown_rsexec_service:
          entry ();

          call initiate_stored_data ();

          rsexec_info$.server_lock_id = ""b;

          call hcs_$wakeup (rsexec_info$.server_process_id, rsexec_info$.listening_channel, 0, err_code);

          return;

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

print_rsexec_status:
          entry ();

          call initiate_stored_data ();

          call set_lock_$lock ((rsexec_info$.server_lock_id), 0, err_code);     /* check validity of copy of lock       */
          if (err_code = 0) | (err_code = error_table_$invalid_lock_reset)
          then do;
               call ioa_ ("RSEXEC service is down.");
               return;
               end;

          call ioa_ ("RSEXEC service being provided by ^a.", rsexec_info$.server_group_id);
          call date_time_ (rsexec_info$.service_start_time, date_string);
          call ioa_ ("Service began at ^a.", date_string);

          call date_time_ (rsexec_info$.scheduled_stop_time, date_string);
          call ioa_ ("Service scheduled to shutdown at ^a.", date_string);

          return;

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

perform_function:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (time_away fixed binary (17),
          (next_logout, next_shut) fixed binary (71),
          shut_reason character (32))
               automatic;

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

          call timer_manager_$reset_alarm_call (recheck_shutdown_time);
          call timer_manager_$alarm_call ((check_interval), "11"b, recheck_shutdown_time);

          call system_info_$next_shutdown (next_shut, shut_reason, (0));

          if next_shut = remembered_shutdown_time
          then return;                                      /* Time hasn't changed, so go away happy          */

          if next_shut < clock_ ()
          then call shutdown_and_reschedule ();

          time_away = divide (next_shut - clock_ (), 60 * MILLION, 17, 0);

          call ioa_ ("Next shutdown in ^d mins for ^a", time_away, shut_reason);

          next_logout = next_shut - 300 * MILLION;          /* we want to logout about 5 mins before system   */

          call timer_manager_$reset_alarm_call (shutdown_and_reschedule);
          call timer_manager_$alarm_call (next_logout, "00"b, shutdown_and_reschedule);

          rsexec_info$.scheduled_stop_time = next_logout;

          remembered_shutdown_time = next_shut;

          return;

end;      /* end perform_function                          */

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

enter_delayed_abs_request:
          procedure (p_time_delay);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_time_delay character (*)
               parameter;

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

          call enter_abs_request (HOME_DIR || ">run_rsexec", "-restart", "-limit", "600", "-queue", "2", "-time", p_time_delay);

          return;

end;      /* end enter_delayed_abs_request                 */

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

initiate_stored_data:
          procedure ();

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

          call hcs_$initiate ((HOME_DIR), "rsexec_info", "rsexec_info", 0b, 0b, (null ()), err_code);
          if (err_code ^= 0) & (err_code ^= error_table_$segknown)
          then call abort_command (err_code, PROG, "Initiating rsexec_info segment.");

          return;

end;      /* end initiate_stored_data                      */

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

process_options:
          procedure (P_arg_list_ptr);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          P_arg_list_ptr pointer
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
          (arg_indx fixed binary (17),
          arg_length fixed binary (24),
          arg_ptr pointer)
               automatic;

          /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */

     declare
          based_argument character (arg_length)
               based;

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

          do arg_indx = 1 repeat (arg_indx + 1) while (got_argument (arg_indx));
               call process_control_argument (arg_ptr -> based_argument);
               end;

          return;

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

got_argument:
          procedure (P_arg) returns (bit (1));

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          P_arg fixed binary (17)                           /* index of the argument which we are to address  */
               parameter;

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

          call cu_$arg_ptr_rel (P_arg, arg_ptr, arg_length, err_code, P_arg_list_ptr);
          if err_code = 0
          then return ("1"b);

          if err_code = error_table_$noarg
          then return ("0"b);

          call abort_command (err_code, PROG, "Attempting to get argument #^d.", P_arg);

end;      /* end got_argument                              */

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

process_control_argument:
          procedure (P_control_arg);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          P_control_arg character (*)
               parameter;

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

          call abort_command (error_table_$badopt, PROG, P_control_arg);

end;      /* end process_control_argument                  */

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

end;      /* end process_options                           */

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

cleanup_after_command:
          procedure ();

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

          return;

end;      /* end cleanup_after_command                     */

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

abort_command_invocation:
          procedure ();

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

          revert error;

          call cu_$gen_call (com_err_, cu_$arg_list_ptr ());

          call cleanup_after_command ();

          goto return_to_caller;

end;      /* end abort_command_invocation                  */

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

          /* end absentee_rsexec                           */
end;




		    rsexec_ascii_.pl1               01/09/80  1047.6rew 01/09/80  0922.2       43299



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

rsexec_ascii_ :
          procedure();

/*
          Program by Gerard J. Rudisin

          This procedure has two entry points which can be used to receive and transmit
          lines of ASCII from and to a foreign RSEXEC server (or to anybody attached with
          net_data_transfer_)

*/

          declare   (
                    working_connection_ptr        pointer,
                    line_ptr                      pointer,
                    line_length                   fixed binary(24),
                    strip_flag                    bit(1),
                    return_code                   fixed binary(35)
                    )                             parameter;

          declare
                    1 ASCII_buffer aligned based (ASCII_buf_ptr),
                      2 workspace aligned,
                        3 byte(0 : 1023) character(1) unaligned;

          declare
                    char_string char(1024) defined (ASCII_buffer.byte);

          declare
                    1 net_buffer aligned automatic,
                      2 workspace aligned,
                        3 byte(0 : 1023) bit(8) unaligned;

          declare
                    found_nl            bit(1),
                    ASCII_buf_ptr       pointer,
                    (num_bytes,
                    next_char,
                    next_net,
                    num_trans,
                    byte_offset
                    )                   fixed binary(24);

          declare
                    iox_$get_chars entry (pointer, pointer, fixed bin(24), fixed bin(24), fixed bin(35)),
                    iox_$put_chars entry (pointer, pointer, fixed bin(24), fixed bin(35)),
                    net_convert_size_$ascii_9_to_8 entry (pointer, pointer, fixed bin(24), fixed bin(24),  fixed bin (24),
                              pointer, fixed bin (24), fixed bin(24), fixed bin(24), fixed bin (35)),
                    net_convert_size_$ascii_8_to_9 entry (pointer, pointer, fixed bin(24), fixed bin(24),  fixed bin (24),
                              pointer, fixed bin (24), fixed bin(24), fixed bin(24), fixed bin (35));

          declare
                    (addr, dimension, hbound, null, substr)           builtin;

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

send_line :
          entry (working_connection_ptr, line_ptr, line_length, return_code);

          ASCII_buf_ptr = line_ptr;

          num_bytes = line_length;
          byte_offset = 0;

          do while(num_bytes > 0);
                    call net_convert_size_$ascii_9_to_8(null(),
                              line_ptr, byte_offset, num_bytes, num_trans,
                              addr(net_buffer.byte), 0, dimension(net_buffer.byte, 1), next_net, (0));
                    call iox_$put_chars(working_connection_ptr, addr(net_buffer.byte), next_net, return_code);
                    if return_code ^= 0 then return;

                    num_bytes = num_bytes - num_trans;
                    byte_offset = byte_offset + num_trans;
                    end;

          return;

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

get_line :
          entry (working_connection_ptr, line_ptr, line_length, strip_flag, return_code);

          ASCII_buf_ptr = line_ptr;
          line_length = 0;
          found_nl = "0"b;

          do next_char = lbound (net_buffer.byte, 1) to hbound(net_buffer.byte, 1) while (^ found_nl);
                    call iox_$get_chars(working_connection_ptr, addr(net_buffer.byte(next_char)),
                              1, num_trans, return_code);
                    if return_code ^= 0 then return;
                    if net_buffer.byte(next_char) = "00001010"b then found_nl = "1"b;
                    end;

          call net_convert_size_$ascii_8_to_9(null(),
                    addr(net_buffer.byte), 0, next_char, (0),
                    ASCII_buf_ptr, 0, dimension(ASCII_buffer.byte, 1), line_length, (0));

          line_length = line_length - 1;

          if strip_flag then if ASCII_buffer.byte(0) = "@" then do;
                    line_length = line_length - 1;
                    substr(char_string, 1, line_length) = substr(char_string, 2, line_length);
                    end;

          return;

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

end rsexec_ascii_;




		    rsexec_establish_conn_.pl1      01/09/80  1047.6rew 01/09/80  0923.0       30177



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

rsexec_establish_conn_:
          procedure(connection_direction, device_spec, asynch_flag, byte_size, connection_iocb_ptr, error_code);


/*

          Program by Gerard J. Rudisin

          Procedure to establish a connection to a foreign RSEXEC server and to
          attach I/O using net_data_transfer_

*/

          declare (
                    connection_direction          fixed binary(17),
                              /*
                                        1 = stream input
                                        2 = stream output
                                        3 = stream input output
                              */
                    device_spec                   character(*),
                    asynch_flag                   bit(1),
                    byte_size                     fixed binary (8),
                    connection_iocb_ptr           pointer,
                    error_code                    fixed binary(35)
                    )                   parameter;


          declare
                    iox_$attach_iocb entry (pointer, char(*), fixed binary(35)),
                    iox_$close entry (pointer,fixed bin(35)),
                    iox_$control entry (pointer,char(*),pointer,fixed bin(35)),
                    iox_$detach_iocb entry (pointer,fixed bin(35)),
                    iox_$find_iocb entry (char(*),pointer,fixed bin(35)),
                    iox_$open entry (pointer,fixed bin(17), bit(1) aligned, fixed bin(35)),
                    unique_chars_ entry (bit(*)) returns (char(15));

          declare
                    null                builtin;

          declare
                    cleanup   condition;

          /* * * * * END OF DECLARATIONS * * * * */



          on cleanup begin;
                    if error_code ^= 0 then if connection_iocb_ptr ^= null() then do;
                              call iox_$close(connection_iocb_ptr,(0));
                              call iox_$detach_iocb(connection_iocb_ptr,(0));
                              end;

                    end;


          connection_iocb_ptr = null();
          error_code = 0;

          call iox_$find_iocb(unique_chars_(""b),connection_iocb_ptr,error_code);
          if error_code ^= 0 then return;

          call iox_$close(connection_iocb_ptr,error_code);
          call iox_$detach_iocb(connection_iocb_ptr,error_code);

          call iox_$attach_iocb(connection_iocb_ptr, device_spec, error_code);
          if error_code ^= 0 then return;

          call iox_$control(connection_iocb_ptr,"setsize",addr (byte_size),error_code);

          if asynch_flag then call iox_$control(connection_iocb_ptr, "asynchronous_open", null(), error_code);

          call iox_$open(connection_iocb_ptr,connection_direction,"0"b,error_code);
          if error_code ^= 0 then return;

          return;

end rsexec_establish_conn_;




		    rsexec_file_server.pl1          01/09/80  1047.6rew 01/09/80  0915.1      189864



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

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
rsexec_file_server :
	procedure();

/*
	Program by Gerard J. Rudisin

	RSEXEC file activity handler. This procedure is called by
	rsexec_server_ when a SUSR command is received; the specified user is logged
	into Multics via the network and this procedure becomes the process
	overseer. It sets up an event call handler which processes file commands
	passed by rsexec_server_.

*/


	declare
		FISH_pointer	pointer internal static init(null());

	declare
		1 duplicate_socket_info(0 : 255) internal static aligned,
		  2 gender		fixed binary(8),
		  2 byte_size		fixed binary(8),
		  2 transfer_mode		fixed binary(8),
		  2 transfer_type		fixed binary(8),
		  2 io_pointer		pointer;

	/* This structure contains duplicate info to the one in the rsexec_server_. This one can be
	   eliminated if the link and file servers are combined in oneprocess
	*/

	/*	file transfer types and modes	*/
	declare
		(STREAM	init(1),
		 BLOCK	init(2),
		 PAGE	init(3),
		 NASCII	init(1),
		 IMAGE	init(2))		fixed binary(8) internal static;


	declare
		(FISH_file_name	char(40),
		person_id		char(23),
		project_id	char(12),
		file_designator_1	char(32),
		file_designator_2	char(32),
		dirname		char(168),
		working_directory	char(168) 
		)		internal static;

	declare
		code		fixed bin(35) internal static,
		temp		fixed bin(17) internal static,
		last_command	fixed bin(17) internal static init(0);

	declare
		1 event_info based,
		  2 channel_id		fixed bin(71),
		  2 message		fixed bin(71),
		  2 sender		bit(36),
		  2 origin,
		    3 dev_signal		bit(18) unaligned,
		    3 ring		bit(18) unaligned,
		  2 data_ptr		pointer;

	declare
                    based_area area based,
		entries (count) bit(144) based (eptr),
		names(total_names) char(32) aligned based (nptr);

	declare
		1 branches internal static unaligned,
		 (2 type		bit(2),
		  2 nname		bit(16),
		  2 nindex	bit(18),
		  2 dtm		bit(36),
		  2 dtu		bit(36),
		  2 mode		bit(5),
		  2 pad		bit(13),
		  2 records	bit(18))	unaligned;

	declare
		program_error	condition;

	declare
		wakeup_pointer		pointer;

	declare
		1 segment_image_template based,
		  2 lots_of_words(262144) bit(36);

	declare
		segment_template char(1048576) based;

	declare
		flinf_area		area(4096) internal static;

	declare
	         (file_pointer_1		pointer,
		file_pointer_2		pointer,
                    area_ptr            pointer,
		eptr			pointer,
		nptr			pointer,
		file_err_switch		bit(1) aligned) internal static;

	declare
		(pin_number		fixed bin(8),
		bit_count_1		fixed bin(24),
		bit_count_2		fixed bin(24),
		(seg_count,
		link_count,
		i,
		count,
		temp1,
		total_names
		)			fixed bin(17) ) internal static;

	declare
		1 segment_acl(2) aligned,
		  2 access_name	char(32) init ("*.CompNet.*",""),
		  2 modes		bit(36) init((2)(1)"101"b),
		  2 pad		bit(36) init((2)(1)"0"b),
		  2 status_code	fixed binary(35);


	/* * * * * * ENTRY & PROCEDURE DECLARATIONS * * * * * */

	declare
		change_wdir_ entry (char(168) aligned,fixed bin(35)),
		com_err_ entry options(variable),
		copy_seg_$no_message entry (char(*),char(*),char(*),char(*),char(*),bit(1) aligned,
			fixed bin(35)),
		delete_$path entry (char(*),char(*),bit(6),char(*),fixed bin(35)),
		get_group_id_$tag_star entry returns(char(32) aligned),
		get_process_id_ entry returns(bit(36)),
                    get_system_free_area_ constant entry () returns (ptr),
		get_wdir_ entry returns(char(168) aligned),
		hcs_$chname_file entry (char(*),char(*),char(*),char(*),fixed bin(35)),
		hcs_$delentry_seg entry  (pointer,fixed bin(35)),
		hcs_$initiate entry (char(*),char(*),char(*),fixed bin(1),fixed bin(2),pointer,fixed bin(35)),
		hcs_$initiate_count entry (char(*),char(*),char(*),fixed bin(24),
			fixed bin(2),pointer,fixed bin(35)),
		hcs_$make_seg entry (char(*),char(*),char(*),fixed bin(5),pointer,fixed bin(35)),
		hcs_$replace_acl entry (char(*),char(*),pointer,fixed bin,bit(1),fixed bin(35)),
		hcs_$set_bc entry (char(*),char(*),fixed bin(24),fixed bin(35)),
		hcs_$set_bc_seg entry (pointer,fixed bin(24),fixed bin(35)),
		hcs_$star_list_ entry (char(*),char(*),fixed bin(3),pointer,fixed bin,fixed bin,
			pointer,pointer,fixed bin(35)),
		hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)), 
		ioa_$rsnnl entry options(variable),
		iox_$attach_ptr entry (pointer,char(*),ptr,fixed bin(35)),
		iox_$close entry (pointer,fixed bin(35)),
		iox_$control entry (pointer,char(*),pointer,fixed bin(35)),
		iox_$detach_iocb entry (pointer,fixed bin(35)),
		iox_$find_iocb entry (char(*),pointer,fixed bin(35)),
		iox_$open entry (pointer,fixed bin,bit(1),fixed bin(35)),
		ipc_$create_ev_chn entry (fixed bin(71),fixed bin(35)),
		ipc_$decl_ev_call_chn entry (fixed bin(71),entry,pointer,fixed bin,fixed bin(35)),
                    net_data_transfer_$net_data_transfer_attach entry (),
		rsexec_file_transfer_$receive_file entry (fixed bin(8), pointer, pointer, fixed bin(24),
			fixed bin(35)),
		rsexec_file_transfer_$send_file entry (fixed bin(8), pointer, pointer, fixed bin(24),
			fixed bin(35)),
		unique_chars_ entry (bit(*)) returns (char(15)),
		user_info_ entry (char(*),char(*));

	declare
		(addr,binary,bit,ceil,divide,fixed,index,mod,null,substr,string)	builtin;

          /* * * * * INCLUDE FILES * * * * * * * * * * * * */

          % include rsexec_fish_dcls;

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


	call user_info_ (person_id, project_id);
	call ioa_$rsnnl (">udd>^a>^a", dirname, (0), project_id, person_id);
	FISH_file_name = rtrim (person_id) || ".ARPA_file_info";

	call hcs_$initiate(dirname,FISH_file_name,"",0b,1b,FISH_pointer,code);
	if FISH_pointer = null() then do;
		call hcs_$make_seg(dirname,FISH_file_name,"",01011b,FISH_pointer,code);
		if FISH_pointer = null() then do;
			go to error_exit;
			end;

		segment_acl(2).access_name = get_group_id_$tag_star();
		call hcs_$replace_acl(dirname,FISH_file_name,addr (segment_acl),2,"0"b,code);
		if code ^= 0 then do;
			call hcs_$delentry_seg(FISH_pointer,(0));
			go to error_exit;
			end;

		end;

	FISH_lock = "0"b;
	file_server_proc_id = get_process_id_();
	call ipc_$create_ev_chn(file_server_channel,code);

	call ipc_$decl_ev_call_chn(file_server_channel,
		file_request_processor,FISH_pointer,1,code);
	if code ^= 0 then go to error_exit;

	working_directory = get_wdir_();
	call com_err_(code,"rsexec_file_server","** SUCCESSFUL SETUP **");
	return;

error_exit :
	call com_err_(code,"rsexec_file_server","** FAILURE **");
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


/*

	The event call channel entry, file_request_processor, is awakened by the system server
	when a file transfer command must be processed. The command line and other pertinent
	information is passed via the FISH segment. Acknowledgements are returned the same way.
	This scheme allows the server to be in complete control of rsexec requests, allowing
	free mixing of file transfer and linking activities.
*/

file_request_processor :
	entry (wakeup_pointer);



	on program_error begin;
		return_file_code = -602;
		return_file_message = "ERROR OCCURRED IN SUSR USER'S PROCESS";
		go to return_to_server;
		end;


	if request < 1 | request > 20 then return;

	/* If RETRV, STORE, NAPN, get the parameters */

	if request = 6 | request = 7 | request = 8 then do;
		pin_number = numeric_parameter(1);
		duplicate_socket_info(pin_number).gender = numeric_parameter(2);
		duplicate_socket_info(pin_number).byte_size = numeric_parameter(3);
		duplicate_socket_info(pin_number).transfer_mode = numeric_parameter(4);
		duplicate_socket_info(pin_number).transfer_type = numeric_parameter(5);

		file_designator_1 = parameter(1);
		if file_designator_1 = "" then do;

file_not_found :
			return_file_code = -40;
			return_file_message = "FILE NOT FOUND";
		          last_command = 0;
			go to return_to_server;
			end;
		end;

	go to file_command(request);

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

	/*	SDIR command	*/
sdir_proc :
file_command(1) :
	working_directory = parameter(1);
	call change_wdir_((working_directory),code);
	if code ^= 0 then do;
		return_file_code = -34;
		return_file_message = "CANNOT SET DIRECTORY";
		end;
	   else do;
		return_file_code = 0;
		end;

	last_command = 0;
	go to return_to_server;
	/*	end SDIR command	*/

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

	/*	DEL command	*/
delete_proc :
file_command(2) :
	file_designator_1 = parameter(1);
	call delete_$path(working_directory,file_designator_1,"100100"b,"",code);
	if code ^= 0 then do;
		return_file_code = -420;
		return_file_message = "CANNOT DELETE FILE";
		end;
	   else return_file_code = 0;

	last_command = 0;
	go to return_to_server;
	/*	end DEL command	*/

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


	/*	REN command	*/
rename_proc :
file_command(3) :
	file_designator_1 = parameter(1);
	file_designator_2 = parameter(2);

	if file_designator_1 = "" | file_designator_2 = "" then do;
		return_file_code = -40;
		return_file_message = "ONE OR BOTH FILENAMES ARE NULL";
		last_command = 0;
		go to return_to_server;
		end;

	call hcs_$chname_file(working_directory,file_designator_1,file_designator_1,
		file_designator_2,code);
	if code ^= 0 then do;
		return_file_code = -421;
		return_file_message = "CANNOT RENAME FILE";
		end;
	   else return_file_code = 0;

	last_command = 0;
	go to return_to_server;
	/*	end REN command	*/

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


	/*	COPY command	*/
copy_proc :
file_command(4) :
	file_designator_1 = parameter(1);
	file_designator_2 = parameter(2);

	call hcs_$initiate(working_directory,file_designator_2,"",0b,1b,file_pointer_2,code);
	if file_pointer_2 ^= null() then do;
	/* give neutral ack that FILE2 exists */
		return_file_code = 30;
		return_file_message = "FILE2 ALREADY EXISTS";
		last_command = 10;
		go to return_to_server;
		end;

copy_anyway :
	call copy_seg_$no_message(working_directory,file_designator_1,
		working_directory,file_designator_2,"rsexec_file_server",
		file_err_switch,code);
	if code ^= 0 then do;
		return_file_code = -431;
		return_file_message = "CANNOT COPY FILE";
		end;

/*	Perhaps add copy_acl for this segment too */
	   else return_file_code = 0;

	last_command = 0;
	go to return_to_server;

	/*	end COPY command	*/

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

	/*	APPN command	*/
append_proc :
file_command(5) :
	file_designator_1 = parameter(1);
	file_designator_2 = parameter(2);

	call hcs_$initiate_count (working_directory,file_designator_1,"",bit_count_1,
		1b,file_pointer_1,code);
	if file_pointer_1 = null() then do;
		return_file_code = -40;
		return_file_message = "FILE1 DOES NOT EXIST";
		last_command = 0;
		go to return_to_server;
		end;

	call hcs_$initiate_count(working_directory,file_designator_2,"",bit_count_2,
		1b,file_pointer_2,code);
	if file_pointer_2 = null() then do;
		/* send neutral acknowledge */
		return_file_code = 31;
		return_file_message = "FILE2 NON EXISTENT";
		last_command = 20;
		go to return_to_server;
		end;
	   else go to append_it;

create_on_append :
	call hcs_$make_seg(working_directory,file_designator_2,"",01011b,file_pointer_2,code);
	if file_pointer_2 = null() then do;
		return_file_code = -412;
		return_file_message = "CANNOT CREATE FILE";
		last_command = 0;
		go to return_to_server;
		end;
	bit_count_2 = 0;

append_it :
          temp = divide(bit_count_1,9,35,0);
	substr(file_pointer_2 -> segment_template,divide(bit_count_2,9,35,0) + 1,temp) =
		substr(file_pointer_1 -> segment_template,1,temp);

	call hcs_$set_bc(working_directory,file_designator_2,bit_count_1 + bit_count_2,code);
	if code ^= 0 then do;
		return_file_code = -413;
		return_file_message = "BIT COUNT COULD NOT BE SET";
		end;
	   else return_file_code = 0;

	last_command = 0;
	go to return_to_server;

	/*	end APPN command	*/

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

	/*	FLINF and DRINF commands	*/
flinf_proc :
file_command(12) :
	file_designator_1 = parameter(1);
	if file_designator_1 = "" then go to file_not_found;
	go to get_status_info;

drinf_proc :
file_command(9) :
	file_designator_1 = "**";
	if parameter(1) = "" then dirname = working_directory;
	   else dirname = parameter(1);

get_status_info :
          area_ptr = get_system_free_area_ ();

	call hcs_$star_list_(dirname,file_designator_1,2,area_ptr,seg_count,link_count,
		eptr,nptr,code);
	if code ^= 0 then do;
		return_file_code = -777;
		return_file_message = "COULD NOT GET FILE OR DIRECTORY INFORMATION";
		last_command = 0;
		go to return_to_server;
		end;

          total_names = 1;
	numeric_parameter(1),count = seg_count + link_count;

	do i = 1 to count;
		string(branches) = entries(i);
		file_designator_2,file_information_block(i).branch_name = names(fixed(branches.nindex,18));
		file_information_block(i).date_time_modified = fixed(branches.dtm,36);
		file_information_block(i).date_time_used = fixed(branches.dtu,36);

		call hcs_$initiate_count(dirname,file_designator_2,"",file_information_block(i).bit_count,
			1b,file_pointer_2,code);
		file_information_block(i).access_privileges = branches.mode;
		file_information_block(i).number_of_records = fixed(branches.records,18);
		end;

	free eptr -> entries in (area_ptr -> based_area);
	free nptr -> names in (area_ptr -> based_area);
	last_command = 0;
	return_file_code = 0;
	go to return_to_server;

	/*	end FLINF, DRINF commands	*/

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

	/*	RETRV command	*/
retrieve_proc :
file_command(6) :
	call hcs_$initiate_count(working_directory,file_designator_1,"",bit_count_1,1b,file_pointer_1,code);
	if file_pointer_1 = null() then go to file_not_found;

	call accept_passoff(pin_number,code,("0"b));
	if code ^= 0 then do;
		return_file_code = -275;
		return_file_message = "COULD NOT ACCEPT PASSOFF";
		last_command = 0;
		go to return_to_server;
		end;

	last_command = 30;
	return_file_code = 0;
	go to return_to_server;

transmit_file :
	call rsexec_file_transfer_$send_file(duplicate_socket_info(pin_number).byte_size,
		addr(duplicate_socket_info(pin_number)),file_pointer_1,bit_count_1,code);

	if code ^= 0 then do;

net_io_error :
		return_file_code = -275;
		return_file_message = "IO ERROR IN FILE TRANSMISSION";
		last_command = 0;
		go to return_to_server;
		end;

	last_command = 0;
	return_file_code = 0;
	go to return_to_server;

	/*	end RETRV command	*/

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

	/* 	STORE command	*/
store_proc :
file_command(7) :
	call hcs_$initiate(working_directory,file_designator_1,"",0b,1b,file_pointer_1,code);
	if file_pointer_1 = null() then do;
		call hcs_$make_seg(working_directory,file_designator_1,"",01011b,file_pointer_1,code);
		if file_pointer_1 = null() then go to file_not_found;
		end;
	bit_count_1 = 0;

	call accept_passoff(pin_number,code,("1"b));
	if code ^= 0 then do;
		return_file_code = -275;
		return_file_message = "IO ERROR IN FILE TRANSMISSION";
		last_command = 0;
		go to return_to_server;
		end;

	last_command = 40;
	return_file_code = 0;
	go to return_to_server;

read_store_file :
	call rsexec_file_transfer_$receive_file(duplicate_socket_info(pin_number).byte_size,
		addr(duplicate_socket_info(pin_number)),file_pointer_1,bit_count_1,code);
	if code ^= 0 then do;
		return_file_code = -275;
		return_file_message = "IO ERROR IN FILE TRANSMISSION";
		last_command = 0;
		go to return_to_server;
		end;

	return_file_code = 0;
	last_command = 0;
	go to return_to_server;

	/* 	end of STORE	*/

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

	/*	NAPN command	*/
nappend_proc :
file_command(8) :
	call hcs_$initiate_count(working_directory,file_designator_1,"",bit_count_1,
		1b,file_pointer_1,code);
	if file_pointer_1 = null() then do;
		return_file_code = 31;
		return_file_message = "FILE NON EXISTENT";
		last_command = 50;
		end;
	   else do;
		return_file_code = 0;
		last_command = 60;
		end;
	go to return_to_server;

create_on_nappend :
	call hcs_$make_seg(working_directory,file_designator_1,"",01011b,file_pointer_1,code);
	if file_pointer_1 = null() then do;
		return_file_code = -412;
		return_file_message = "CANNOT CREATE FILE";
		last_command = 0;
		go to return_to_server;
		end;

	bit_count_1 = 0;

	last_command = 60;
	return_file_code = 0;
	go to return_to_server;

read_append_file :
	call accept_passoff(pin_number,code,("1"b));
	if code ^= 0 then do;

napn_io_error :
		return_file_code = -275;
		return_file_message = "IO ERROR IN FILE TRANSMISSION";
		last_command = 0;
		go to return_to_server;
		end;

	temp = duplicate_socket_info(pin_number).byte_size;
	call hcs_$make_seg("", "", "", 01011b, file_pointer_2, code);
	/*	this creates temporary segment in process dir	*/
	if file_pointer_2 = null() then go to napn_error;

	call rsexec_file_transfer_$receive_file(binary (temp, 8), addr(duplicate_socket_info(pin_number)),
		file_pointer_2, bit_count_2, code);
	if code ^= 0 then go to napn_io_error;

	temp1 = ceil(bit_count_1 / temp);
	do count = 1 to ceil(bit_count_2 / temp);
		file_pointer_1 -> segment_image_template.lots_of_words(temp1 + count) =
			file_pointer_2 -> segment_image_template.lots_of_words(count);
		end;

	call hcs_$set_bc_seg(file_pointer_1,bit_count_1 + bit_count_2,code);
	if code ^= 0 then do;

napn_error :
		return_file_code = -414;
		return_file_message = "COULD NOT FINISH APPEND";
		end;
	   else return_file_code = 0;

	last_command = 0;
	go to return_to_server;

	/*	end of NAPN	*/

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

	/*	"+" command from neutral ack	*/
plus_proc :
file_command(10) :
	if last_command = 10 then go to copy_anyway;
	if last_command = 20 then go to create_on_append;
	if last_command = 30 then go to transmit_file;
	if last_command = 40 then go to read_store_file;
	if last_command = 50 then go to create_on_nappend;
	if last_command = 60 then go to read_append_file;

	return_file_code = -11;
	return_file_message = "UNRECOGNIZED USE OF + AS A COMMAND";
	last_command = 0;
	go to return_to_server;

	/*	end of "+" command 	*/

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

	/*	"-" command from neutral ack	*/
minus_proc :
file_command(11) :
	if last_command = 10 | last_command = 20 | last_command = 30 | last_command = 40 | last_command = 50 |
	   last_command = 60 then return_file_code = 0;
	   else do;
		return_file_code = -11;
		return_file_message = "UNRECOGNIZED USE OF - AS A COMMAND";
		end;

	last_command = 0;
	go to return_to_server;

	/*	end of "-" command	*/

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



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

return_to_server :
	call hcs_$wakeup(system_server_proc_id,system_server_channel,(0),code);
	return;

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

accept_passoff :
	procedure(pin_number,return_code,read_flag);

	declare
		(pin_number	fixed bin(8),
		 return_code	fixed bin(35),
		 read_flag	bit(1))			parameter;

	declare
		temp		fixed bin(35),
		code		fixed bin(35),
		iocb_ptr		pointer,
		device_spec	char(128);

	/*	END of DECLARATIONS		*/

	return_code = 0;

	call iox_$find_iocb(unique_chars_(""b),iocb_ptr,code);
	if code ^= 0 then go to error_exit;

	duplicate_socket_info(pin_number).io_pointer = iocb_ptr;
	call iox_$close(iocb_ptr,code);
	call iox_$detach_iocb(iocb_ptr,code);

	call ioa_$rsnnl ("net_data_transfer_ -connect none -userid ^d -local_pin ^d", device_spec, (0), 
                    binary (server_network_userid, 24), pin_number - mod (pin_number, 2));

	call iox_$attach_ptr (iocb_ptr, device_spec, addr (net_data_transfer_$net_data_transfer_attach), code);
	if code ^= 0 then go to error_exit;
	temp = duplicate_socket_info(pin_number).byte_size;
	call iox_$control(iocb_ptr,"setsize",addr(temp),code);

	if read_flag then call iox_$open(iocb_ptr,1,"0"b,code);
	   else call iox_$open(iocb_ptr,2,"0"b,code);
	if code ^= 0 then go to error_exit;

	return;

error_exit :
	return_code = code;
	return;

end accept_passoff;

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

end rsexec_file_server;




		    rsexec_file_transfer_.pl1       01/09/80  1048.4rew 01/09/80  0923.0       62883



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

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

rsexec_file_transfer_ :
	procedure ();

/*

	Program by Gerard J. Rudisin

*/

	declare	(
		file_byte_size	fixed binary(17),
		info_pointer	pointer,
		file_pointer	pointer,
		new_file_bit_count	fixed binary(24),
		bit_count		fixed binary(24),
		return_code	fixed binary(35)
		)		parameter;

	declare
		1 socket_information based (info_pointer),
		  2 gender		fixed binary(8),
		  2 connection_byte_size	fixed binary(8),
		  2 transfer_mode		fixed binary(8),
		  2 transfer_type		fixed binary(8),
		  2 stream_pointer		pointer;

	declare
		1 block_template aligned,
		  2 num_bytes	fixed binary(24),
		  2 byte_offset	fixed binary(24),
		  2 buffer,
		    3 byte(0 : 513) bit(36) unaligned;

	declare
		1 segment_image_template based,
		  2 lots_of_words(262144) bit(36);

	declare
		block_control(2)	fixed bin(35) aligned,
		byte_count	fixed bin(35),
		byte_size		fixed bin(35),
		temp35		fixed binary(35),
		temp24		fixed binary(24),
                    temp_word           bit (36),
		(temp,
		temp1,
		bytes_left,
		count,
		seg_offset	init(1),
		file_offset	init(0))	fixed binary(17);

	declare
		mode_offset	fixed binary(8) init(0);

	declare	(
		STREAM	init(1),
		BLOCK	init(2),
		PAGE	init(3),
		NASCII	init(1),
		IMAGE	init(2))		fixed binary(8) internal static;

	declare	(
		READ	init(2),
		WRITE	init(1))		fixed binary(8) internal static;

	declare	(
		error_table_$improper_data_format,
		error_table_$invalid_elsize,
		error_table_$net_bad_gender
		)		fixed binary(35) external static;


	/* * * * * * ENTRY & PROCEDURE DECLARATIONS * * * * * */

	declare
		hcs_$set_bc_seg entry (pointer, fixed bin(24), fixed bin(35)),
		iox_$get_chars entry(pointer, pointer, fixed bin(24), fixed bin(24), fixed bin(35)),
		iox_$put_chars entry(pointer, pointer, fixed bin(24), fixed bin(35));

	declare
		(addr,binary,bit,ceil,fixed,min,mod,substr,unspec)	builtin;

/* * * * * * * * * * * * * * * * * * * * * * * * * */

receive_file :
	entry (file_byte_size, info_pointer, file_pointer, new_file_bit_count, return_code);


	new_file_bit_count = 0;

	if gender ^= READ then do;
		return_code = error_table_$net_bad_gender;
		return;
		end;

	if transfer_mode = BLOCK then call iox_$get_chars(stream_pointer,addr(byte_size),1,(0),return_code);
	   else if transfer_mode = PAGE then call iox_$get_chars(stream_pointer,addr(block_control),2,(0),return_code);
	if return_code ^= 0 then return;

	if transfer_mode = PAGE then do;
		byte_size = binary(substr(bit(block_control(1)),7,6),35);
		byte_count = block_control(2);
		end;

	if byte_size ^= file_byte_size then do;
		return_code = error_table_$invalid_elsize;
		return;
		end;

	do while("1"b);
		/*	get block control info for each block	*/
		call iox_$get_chars(stream_pointer,addr(block_control(1)),1,(0),return_code);
		if return_code ^= 0 then return;
	
		if block_control(1) = -1 then go to done;

		if transfer_mode = BLOCK then call iox_$get_chars(stream_pointer,addr(block_control(2)),1,(0),return_code);
		/* block_control(2) = number of 36 bit words in block */

		if transfer_mode = BLOCK then temp24 = block_control(2);
		   else if transfer_mode = PAGE then temp24 = 512;
		call iox_$get_chars(stream_pointer,addr(block_template.byte),temp24,block_template.num_bytes,return_code);
		if return_code ^= 0 then return;

		new_file_bit_count = new_file_bit_count + block_template.num_bytes;
		/* actually byte count for now */


		do temp = 0 to block_template.num_bytes;
			file_pointer -> segment_image_template.lots_of_words(seg_offset + temp) =
				block_template.byte(temp);
			end;

		seg_offset = seg_offset + block_template.num_bytes;
		end;

	return_code = error_table_$improper_data_format;
	return;
/*	end of file not found, indicating protocol violation	*/

done :
	if transfer_mode = BLOCK then new_file_bit_count = new_file_bit_count * connection_byte_size;
	   else if transfer_mode = PAGE then new_file_bit_count = byte_size * byte_count;
	return_code = 0;

	call hcs_$set_bc_seg(file_pointer, new_file_bit_count, return_code);

	return;

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

send_file :
	entry (file_byte_size, info_pointer, file_pointer, bit_count, return_code);


	return_code = 0;
	bytes_left = ceil(bit_count/file_byte_size);

	if gender ^= WRITE then do;
		return_code = error_table_$net_bad_gender;
		return;
		end;

/*	send out the appropriate header	*/

	temp_word = bit (binary (connection_byte_size, 36));
	if transfer_mode = BLOCK
          then call iox_$put_chars(stream_pointer, addr(temp_word), (1), return_code);
	else if transfer_mode = PAGE then do;
		temp = ceil(bytes_left / 512);
		temp_word = (6)"0"b || bit (binary (connection_byte_size, 6)) || (6)"0"b || bit(binary (temp, 17));
/* this sure looks wrong, are things supposed to be shifted left one bit ?? */

		call iox_$put_chars(stream_pointer, addr(temp_word), (1), return_code);
		if return_code ^= 0 then return;

		temp_word = bit (binary (bytes_left, 36));
		call iox_$put_chars(stream_pointer, addr(temp_word), (1), return_code);

		end;

	if return_code ^= 0 then return;

	do count = 1 to ceil(bytes_left/512.0);
		temp = min(bytes_left,512);
		bytes_left = bytes_left - temp;

		if transfer_mode = BLOCK then do;
			mode_offset = 1;
			block_template.byte(0) = bit(fixed(count,18)) || bit(fixed(temp,18));
			block_template.byte(1) = (18)"0"b || bit(fixed(temp,18));
			end;
		   else if transfer_mode = PAGE then block_template.byte(0) = (18)"0"b || bit(fixed(count,18));

		do temp1 = 1 to temp;
			block_template.byte(mode_offset + temp1) = file_pointer ->
				segment_image_template.lots_of_words(temp1 + file_offset);
			end;

		file_offset = file_offset + temp;
		block_template.num_bytes = temp + mode_offset + 1;

		call iox_$put_chars(stream_pointer,addr(block_template.byte),
			block_template.num_bytes,return_code);
		if return_code ^= 0 then return;

		end;

/*	If PAGE transfer_mode, pad the last page with zeroes	*/
	if transfer_mode = PAGE then if mod(temp,512) ^= 0 then do;
		do count = 0 to temp - 1;
			block_template.byte(count) = "0"b;
			end;

		call iox_$put_chars(stream_pointer,addr(block_template.byte),(temp),return_code);
		if return_code ^= 0 then return;

		end;

	temp_word = (36)"1"b;
	call iox_$put_chars(stream_pointer, addr(temp_word), (1), return_code);
	if return_code ^= 0 then return;

	return;

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

end rsexec_file_transfer_;




		    rsexec_link.pl1                 01/09/80  1048.4rew 01/09/80  0929.8      209061



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

rsexec_link:
          procedure ();

/*             "rsexec_link" -- program to create a full-duplex communication   */
/*        channel between a local Multics user and a user at an foreign ARPANET */
/*        host.  The RSEXEC protocol is used to create and maintain the         */
/*        connection.  It is assumed that the connection is to be used for      */
/*        interactive character conversations in ASCII.                         */

/*        Originally written by D. M. Wells in ancient times as a rewrite of    */
/*             an earlier version written and maintained(?) by others.  That    */
/*             earlier version had proved to be totally inamenable to efforts   */
/*             to improve its diagnostic and maintenance characteristics.       */
/*        Modified by D. M. Wells, July 3, 1977, to use new iox_ features and   */
/*             new net_ascii_ interface conventions.                            */
/* Last modified:	10 march 1978 by G. Palter to add '-at' and fix blocking
		strategy.
   */

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (first_pin fixed binary (8),
          host_number fixed binary (16),
          num_args fixed binary (17),
          socket_number fixed binary (32),
          err_code fixed binary (35),
          tracing bit (1),
          unique_name character (15),
          user_name character (64),
          (control_iocb, rcv_iocb, xmit_iocb) pointer)
               automatic;

     declare
          abort_command variable entry options (variable) initial (abort_command_invocation)
               automatic;

          /* * * * * INTERNAL STATIC DECLARATIONS  * * * * */

          /* * * * * TEXT SECTION REFERENCES * * * * * * * */

     declare
         (DEL bit (9) initial ("177"b3),
          PROG character (32) initial ("rsexec_link"))
               internal static options (constant);

          /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */

          /* * * * * EXTERNAL STATIC DECLARATIONS  * * * * */

     declare
         (iox_$user_input,
          iox_$user_output)
               pointer external static;

     declare
         (error_table_$badopt,
          error_table_$noarg)
               fixed binary (35) external static;

          /* * * * * ENTRY & PROCEDURE DECLARATIONS  * * * */

     declare
          com_err_ constant entry options (variable),
          cu_$arg_count constant entry (fixed bin (17)),
          cu_$arg_list_ptr constant entry () returns (ptr),
          cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr),
          cu_$gen_call constant entry (entry, ptr),
          cv_dec_check_ constant entry (char (*), fixed bin (35)) returns (fixed bin (35)),
          cv_oct_check_ constant entry (char (*), fixed bin (35)) returns (fixed bin (35)),
          host_id_$check_id constant entry (char (*), bit (1), fixed bin (16), bit (1), fixed bin (35)),
          host_id_$symbol constant entry (fixed bin (16), char (*), fixed bin (35)),
          ioa_ constant entry options (variable),
          ioa_$rsnnl constant entry options (variable),
          ioa_$ioa_switch constant entry options (variable),
          iox_$attach_ptr constant entry (ptr, char (*), ptr, fixed bin (35)),
          iox_$close constant entry (ptr, fixed bin (35)),
          iox_$control constant entry (ptr, char (*), ptr, fixed bin (35)),
          iox_$destroy_iocb constant entry (ptr, fixed bin (35)),
          iox_$detach_iocb constant entry (ptr, fixed bin (35)),
          iox_$find_iocb constant entry (char (*), ptr, fixed bin (35)),
          iox_$get_line constant entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35)),
          iox_$modes constant entry (ptr, char (*), char (*), fixed bin (35)),
          iox_$open constant entry (ptr, fixed bin (17), bit (1) aligned, fixed bin (35)),
          iox_$put_chars constant entry (ptr, ptr, fixed bin (24), fixed bin (35)),
          ipc_$block constant entry (ptr, ptr, fixed bin (35)),
          ncp_$get_userid constant entry (fixed bin (24), fixed bin (35)),
          ncp_$local_host_number constant entry (fixed bin (16), fixed bin (35)),
	net_ascii_$net_ascii_attach constant entry,
          net_pin_manager_$allocate_pins constant entry (fixed bin (8), fixed bin (8), fixed bin (35)),
          net_pin_manager_$free_pins constant entry (fixed bin (8), fixed bin (8), fixed bin (35)),
          unique_chars_ constant entry (bit (*)) returns (char (15)),
          user_info_ constant entry (char (*), char (*), char (*));

     declare
          (addr, index, length, mod, null, search, substr)
               builtin;

          /* * * * * STACK REFERENCES  * * * * * * * * * * */

     declare
          cleanup condition;

          /* * * * * INCLUDE FILES * * * * * * * * * * * * */

          % include net_event_template;

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

          err_code = 0;

          call cu_$arg_count (num_args);

          if num_args = 0
          then do;
               call ioa_ ("Usage is:^/^10x^a user -at foreign_host", PROG);
               return;
               end;

          first_pin = -1;
          control_iocb = null ();
          xmit_iocb = null ();
          rcv_iocb = null ();

          call process_options (cu_$arg_list_ptr ());

          on cleanup
               call cleanup_after_command ();

          unique_name = unique_chars_ (""b);

          call iox_$find_iocb ("rsexec_control_." || unique_name, control_iocb, err_code);
          call iox_$find_iocb ("rsexec_rcv_." || unique_name, rcv_iocb, err_code);
          call iox_$find_iocb ("rsexec_xmit_." || unique_name, xmit_iocb, err_code);

          call net_pin_manager_$allocate_pins (6, first_pin, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Allocating network pins.");

          call setup_connections ();

          call perform_function ();

          call cleanup_after_command ();

return_to_caller:
          return;

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

perform_function:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (num_read fixed binary (24),
          did_anything bit (1),
          continue_communication bit (1),
          input_line character (512))
               automatic;

     declare
          1 wait_list aligned automatic,
             2 num_channels fixed binary (17),
             2 padding bit (36),
             2 channel (2) fixed binary (71);

     declare
          1 event_message aligned automatic like event_message_template;

     declare
          1 read_status aligned automatic,
             2 event_channel fixed binary (71),
             2 input_available bit (1) unaligned,
             2 padding bit (35) unaligned;

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

          wait_list.num_channels = 1;

          call ioa_ ("Input.");

          continue_communication = "1"b;
          do while (continue_communication);
               did_anything = "0"b;

               call iox_$control (rcv_iocb, "read_status", addr (read_status), err_code);
               if err_code ^= 0
               then call abort_command (err_code, PROG, "Network link.");

               wait_list.channel (2) = read_status.event_channel;
	     wait_list.num_channels = 2;

               if read_status.input_available
               then do;
                    did_anything = "1"b;

                    call iox_$get_line (rcv_iocb, addr (input_line), length (input_line), num_read, err_code);
                    if err_code ^= 0
                    then call abort_command (err_code, PROG, "Reading from network link.");

                    call iox_$put_chars (iox_$user_output, addr (input_line), num_read, err_code);
                    if err_code ^= 0
                    then call abort_command (err_code, PROG, "Writing to user_output");
                    end;

               call iox_$control (iox_$user_input, "read_status", addr (read_status), err_code);
               if err_code ^= 0
               then call abort_command (err_code, PROG, "user_input");

               wait_list.channel (1) = read_status.event_channel;

               if read_status.input_available
               then do;
                    did_anything = "1"b;

                    call iox_$get_line (iox_$user_input, addr (input_line), length (input_line), num_read, err_code);
                    if err_code ^= 0
                    then call abort_command (err_code, PROG, "Reading from user_input");

                    if (num_read = 2) & (substr (input_line, 1, 1) = ".")
                    then continue_communication = "0"b;
                    else do;
                         call iox_$put_chars (xmit_iocb, addr (input_line), num_read, err_code);
                         if err_code ^= 0
                         then call abort_command (err_code, PROG, "Writing to rsexec link connection.");
                         end;
                    end;

               if ^ did_anything
               then do;
                    call ipc_$block (addr (wait_list), addr (event_message), err_code);
                    if err_code ^= 0
                    then call abort_command (err_code, PROG, "Blocking on ipc channels.");
                    end;
               end;

          call ioa_$ioa_switch (xmit_iocb, "Breaking link.");

          return;

end;      /* end perform_function                          */

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

setup_connections:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (this_host_number fixed binary (16),
          (rcv_handle, xmit_handle) character (24) varying,
          (this_host, this_proj, this_user) character (32),
          attach_description character (96),
          reply_message character (256) varying)
               automatic;

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

          call ioa_$rsnnl ("net_ascii_ ^d,^d -connect icp -local_pin ^d", attach_description, (0),
                    host_number, socket_number, first_pin);

          if tracing
          then call ioa_ ("T:  attach description is ^a", attach_description);

          call iox_$attach_ptr (control_iocb, attach_description, addr (net_ascii_$net_ascii_attach), err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Attaching control stream.");

          call iox_$open (control_iocb, 3, "0"b, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Opening control connection.");

          if tracing
          then call ioa_ ("T:  control stream is open");

          call ioa_$ioa_switch (control_iocb, "ERSTR");
          if ^ get_ack (reply_message)
          then call abort_command (0, PROG, reply_message);

          call open_LINK_socket ("S", first_pin + 4, 1, rcv_iocb, rcv_handle, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Opening receive link connection.");

          call open_LINK_socket ("R", first_pin + 5, 2, xmit_iocb, xmit_handle, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Opening transmit link connection.");

          if tracing
          then call ioa_ ("T:  Link handles -- read:  ^a, write:  ^a", rcv_handle, xmit_handle);

          call ioa_$ioa_switch (control_iocb, "LINK ^a ^a ^a", rcv_handle, xmit_handle, user_name);

          if ^ get_ack (reply_message)
          then call abort_command (0, PROG, reply_message);

          call iox_$modes (xmit_iocb, "rawo", (""), err_code);
          call iox_$put_chars (xmit_iocb, addr (DEL), 1, err_code);
          call iox_$modes (xmit_iocb, "^rawo,^ll,^pl,^tabs", (""), err_code);

          call ncp_$local_host_number (this_host_number, (0));
          call host_id_$symbol (this_host_number, this_host, err_code);

          call user_info_ (this_user, this_proj, (""));
          call ioa_$ioa_switch (xmit_iocb, "^/RSEXEC LINK from ^a.^a at ^a", this_user, this_proj, this_host);
          call ioa_$ioa_switch (xmit_iocb, "(Communication is on a line-by-line basis.)");

          return;

end;      /* end setup_connections                         */

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

get_ack:
          procedure (p_reply_message) returns (bit (1));

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_reply_message character (*) varying
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         ((num_in, sign_loc) fixed binary (24),
          response_line character (512),
          reply_message character (512) varying)
               automatic;

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

          p_reply_message = "";

          call iox_$get_line (control_iocb, addr (response_line), length (response_line), num_in, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "Waiting for command response");

          if tracing
          then call ioa_ ("T:  response -- ^a", substr (response_line, 1, num_in - 1));

          sign_loc = search (substr (response_line, 1, num_in), "+-");
          if sign_loc = 0
          then call abort_command (0, PROG, "Bad response from server.");

          reply_message = substr (response_line, sign_loc, num_in - sign_loc);
          if substr (reply_message, length (reply_message), 1) = "+"
          then reply_message = substr (reply_message, 1, length (reply_message) - 1);
                                                  /* compiler error if we just check the last char            */

          p_reply_message = reply_message;

          return (substr (response_line, sign_loc, 1) = "+");

end;      /* end get_ack                                   */

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

open_LINK_socket:
          procedure (p_direction_char, p_local_pin, p_open_mode, p_iocb, p_handle, p_err_code);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
         (p_local_pin fixed binary (8),
          p_open_mode fixed binary (17),
          p_err_code fixed binary (35),
          p_direction_char character (1),
          p_handle character (*) varying,
          p_iocb pointer)
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (net_userid fixed binary (24),
          space_loc fixed binary (24),
          (foreign_socket, local_socket) fixed binary (32),
          attach_desc character (96),
          reply_message character (256) varying)
               automatic;

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

          call ncp_$get_userid (net_userid, (0));

          local_socket = net_userid * 256 + p_local_pin;

          call ioa_$ioa_switch (control_iocb, "AUXS ^1a 8", p_direction_char);
          if ^ get_ack (reply_message)
          then call abort_command (0, PROG, reply_message);

          space_loc = index (reply_message, " ");
          foreign_socket = cv_oct_check_ (substr (reply_message, 2, space_loc - 2), err_code);
          if err_code ^= 0
          then call abort_command (0, PROG, "Improper response to AUXS:  ^a", reply_message);

          p_handle = substr (reply_message, space_loc + 1);

          call ioa_$rsnnl ("net_ascii_ ^d,^d -connect initiate -local_pin ^d", attach_desc, (0),
                    host_number, foreign_socket - mod (foreign_socket, 2), p_local_pin - mod (p_local_pin, 2));

          if tracing
          then call ioa_ ("T:  attach description for ^a connection is ^a", p_direction_char, attach_desc);

          call iox_$attach_ptr (p_iocb, attach_desc, addr (net_ascii_$net_ascii_attach), p_err_code);
          if p_err_code ^= 0
          then call abort_command (p_err_code, PROG, "Attaching link socket.");

          call iox_$control (p_iocb, "asynchronous_open", null (), p_err_code);

          call iox_$open (p_iocb, p_open_mode, "0"b, p_err_code);
          if p_err_code ^= 0
          then call abort_command (p_err_code, PROG, "Opening link connection.");

          if tracing
          then call ioa_ ("T:  attempting CONN to ^a from local socket ^d", p_handle, local_socket);

          call ioa_$ioa_switch (control_iocb, "CONN ^a ^o", p_handle, local_socket);

          if ^ get_ack (reply_message)
          then call abort_command (0, PROG, reply_message);

          call iox_$control (p_iocb, "complete_open", null (), p_err_code);
          if p_err_code ^= 0
          then call abort_command (p_err_code, PROG, "Completing open of link connection.");

          if tracing
          then call ioa_ ("T:  ^a connection is open.", p_direction_char);

          return;

end;      /* end open_LINK_socket                          */

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

process_options:
          procedure (p_arg_list_ptr);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_arg_list_ptr pointer
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
          (arg_indx fixed binary (17),
          arg_length fixed binary (24),
          arg_ptr pointer)
               automatic;

          /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */

     declare
          based_argument character (arg_length)
               based;

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

          tracing = "0"b;

          host_number = -1;
          socket_number = 245;
          user_name = "";

          do arg_indx = 1 repeat (arg_indx + 1) while (got_argument (arg_indx));
               call process_control_argument (arg_ptr -> based_argument);
               end;

          if host_number = -1
          then call abort_command (0, PROG, "No host specified.");

          if user_name = ""
          then call abort_command (0, PROG, "No user specified.");

          if tracing
          then call ioa_ ("T:  User is ^a at host ^d.", user_name, host_number);

          return;

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

got_argument:
          procedure (p_arg) returns (bit (1));

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_arg fixed binary (17)                           /* index of the argument which we are to address  */
               parameter;

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

          call cu_$arg_ptr_rel (p_arg, arg_ptr, arg_length, err_code, p_arg_list_ptr);
          if err_code = 0
          then return ("1"b);

          if err_code = error_table_$noarg
          then return ("0"b);

          call abort_command (err_code, PROG, "Attempting to get argument #^d.", p_arg);

end;      /* end got_argument                              */

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

process_control_argument:
          procedure (p_control_arg);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_control_arg character (*)
               parameter;

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

          if substr (p_control_arg, 1, 1) ^= "-"
          then do;                                          /* no leading "-", must be user name              */
               if user_name ^= ""
               then call abort_command (0, PROG, "Only one user name may be specified.");

               user_name = p_control_arg;
               return;
               end;

          if (p_control_arg = "-host") | (p_control_arg = "-at")
          then do;
               arg_indx = arg_indx + 1;
               if ^ got_argument (arg_indx)
               then call abort_command (error_table_$noarg, PROG, "The -host control argument requires a host name.");

               call host_id_$check_id (arg_ptr -> based_argument, "0"b, host_number, (""b), err_code);
               if err_code ^= 0
               then call abort_command (err_code, PROG, arg_ptr -> based_argument);

               return;
               end;

          if (p_control_arg = "-socket") | (p_control_arg = "-sc")
          then do;
               arg_indx = arg_indx + 1;
               if ^ got_argument (arg_indx)
               then call abort_command (error_table_$noarg, PROG, "The -socket control argument requires a socket number.");

               socket_number = cv_dec_check_ (arg_ptr -> based_argument, err_code);
               if err_code ^= 0
               then call abort_command (0, PROG, "Not a decimal number:  ^a", arg_ptr -> based_argument);

               return;
               end;

          if (p_control_arg = "-debug")
          then do;
               tracing = "1"b;
               return;
               end;

          call abort_command (error_table_$badopt, PROG, p_control_arg);

end;      /* end process_control_argument                  */

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

end;      /* end process_options                           */

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

cleanup_after_command:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
          iocb_ptr pointer
               automatic;

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

          do iocb_ptr = control_iocb, xmit_iocb, rcv_iocb;
               if iocb_ptr ^= null ()
               then do;
                    call iox_$close (iocb_ptr, (0));
                    call iox_$detach_iocb (iocb_ptr, (0));
                    call iox_$destroy_iocb (iocb_ptr, (0));
                    end;
               end;

          if first_pin ^= -1
          then do;
               call net_pin_manager_$free_pins (6, first_pin, (0));
               end;
          return;

end;      /* end cleanup_after_command                     */

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

abort_command_invocation:
          procedure ();

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

          call cu_$gen_call (com_err_, cu_$arg_list_ptr ());

          call cleanup_after_command ();

          goto return_to_caller;

end;      /* end abort_command_invocation                  */

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

          /* end rsexec_link                               */
end;




		    rsexec_requests_.pl1            01/09/80  1048.4rew 01/09/80  0923.0       37395



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

rsexec_requests_ :
	procedure();

/*

	Program by Gerard J. Rudisin

*/

	declare	(
		auxs_direction		char(1),
		auxs_for_socket		fixed binary(32),
		auxs_handle		fixed binary(8),
		auxs_pin			fixed binary(8),
		auxs_ptr			pointer,
		auxs_size			fixed binary(8),

		working_connection_ptr	pointer,
		foreign_host		fixed binary(8),
		error_code		fixed binary(35)
		)			parameter;

	declare
		network_uid		fixed binary(24),
		device_spec		char(96),
		request			char(64),
		response			char(64);

	declare
		request_length		fixed bin(24),
		response_length		fixed bin(24),
		temp			fixed bin(17);

	declare
		error_table_$action_not_performed	external static fixed binary(35);

	/* * * * * * ENTRY & PROCEDURE DECLARATIONS * * * * * */

	declare
		cv_dec_ entry (char(*)) returns (fixed bin(35)),
		cv_oct_ entry (char(*)) returns (fixed bin(35)),
		rsexec_establish_conn_ entry (fixed bin(17), char(*), bit (1), fixed bin (8),
			pointer, fixed bin(35)),
		ioa_$rs entry options(variable),
		ioa_$rsnnl entry options (variable),
		iox_$control entry (pointer, char(*), pointer, fixed bin(35)),
		ncp_$get_userid entry (fixed bin(24), fixed bin(35)),
		net_pin_manager_$allocate_pins entry (fixed bin(8), fixed bin(8), fixed bin(35)),
		rsexec_ascii_$get_line entry (pointer, pointer, fixed bin(24), bit(1), fixed bin(35)),
		rsexec_ascii_$send_line entry (pointer, pointer, fixed bin(24), fixed bin(35));

	declare
		(addr, index, mod, null, substr)	builtin;

	/* * * * * * END OF DECLARATIONS * * * * * */

make_auxs_conn :
	entry(working_connection_ptr, foreign_host, auxs_direction, auxs_size, auxs_handle, 
		auxs_pin, auxs_for_socket, auxs_ptr, error_code);

	error_code = 0;
	call ncp_$get_userid(network_uid, error_code);
	if error_code ^= 0 then return;

	call ioa_$rs("AUXS ^a ^d", request, request_length, auxs_direction, auxs_size);
	call rsexec_ascii_$send_line(working_connection_ptr, addr (request), request_length, error_code);
	if error_code ^= 0 then return;

	call rsexec_ascii_$get_line(working_connection_ptr, addr (response), response_length, "1"b, error_code);
	if substr(response,1,1) ^= "+" | error_code ^= 0 then go to auxs_conn_error;

	temp = index(response, " ");
	auxs_for_socket = cv_oct_(substr(response, 2, temp - 2));
	auxs_handle = cv_dec_(substr(response, temp + 1, response_length - temp));

	call net_pin_manager_$allocate_pins(2, auxs_pin, error_code);
	if error_code ^= 0 then return;

	if auxs_direction = "S" then temp = 1 ; /* local socket is stream input */
	   else if auxs_direction = "R" then do; /* local socket is stream output */
                    temp = 2;
                    auxs_pin = auxs_pin + 1;
                    end;
	call ioa_$rsnnl("net_data_transfer_ ^d,^d -local_pin ^d -connect initiate", device_spec, (0), foreign_host, 
		auxs_for_socket - mod(auxs_for_socket, 2), auxs_pin - mod(auxs_pin, 2));

	call ioa_$rs("CONN ^d ^o", request, request_length, auxs_handle, network_uid * 256 + auxs_pin);
	call rsexec_establish_conn_(temp, device_spec, "1"b, auxs_size, auxs_ptr, error_code);
	if error_code ^= 0 then return;

	call rsexec_ascii_$send_line(working_connection_ptr, addr (request), request_length, error_code);
	if error_code ^= 0 then return;

	call rsexec_ascii_$get_line(working_connection_ptr, addr (response), response_length, "1"b, error_code);
	if error_code ^= 0 | substr(response,1,1) ^= "+" then go to auxs_conn_error;

	call iox_$control(auxs_ptr, "complete_open", null(), error_code);
	if error_code ^= 0 then return;

	return;

auxs_conn_error :
	if error_code = 0 then error_code = error_table_$action_not_performed;
	return;

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

end rsexec_requests_;




		    rsexec_server_.pl1              01/09/80  1048.4rew 01/09/80  0930.2      960723



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

rsexec_server_:
          procedure (P_iocb_ptr, P_foreign_host, P_foreign_socket, P_info_bits, P_error_code);

/*

          Program by Gerard J. Rudisin

          "rsexec_server_" is a series of procedures which implements the RSEXEC protocol
          for communication and resource sharing over the ARPA network. The protocol was
          developed by Bob Thomas of BBN and is oriented to use on TENEX systems. This
          is the first pass at a Multics implementation.

          "rsexec_server_" is called from run_rsexec_server when a foreign
          host desires to establish communication with the Multics
          server. Each such request for connection results in the
          invocation of rsexec_server_ as a separate task in the
          server process.

          The original versions of the setup and IO modules are
          the work of Doug Wells, 545 Tech Square.


*/

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
         (P_foreign_host fixed binary (16),
          P_foreign_socket fixed binary (32),
          P_error_code fixed binary (35),
          P_info_bits bit (*),
          P_iocb_ptr pointer)
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */

          declare
                    tracing bit (1) aligned automatic,
                    abort_instance entry options (variable) initial (error_handler) automatic;

          /* * * * * INTERNAL STATIC DECLARATIONS  * * * * */

          /* * * * * EXTERNAL STATIC DECLARATIONS  * * * * */

          declare
                    ascii_value_$SP     bit(9) external static;

          declare
                    (error_table_$invalid_lock_reset,
                     error_table_$lock_wait_time_exceeded,
                     error_table_$end_of_info,
                     error_table_$short_record
                    )                   fixed binary(35) external static;

          /* * * * * STACK REFERENCES  * * * * * * * * * * */

          declare   (
                    program_interrupt,
                    error
                    )                   condition;


/*
          SHARED SEGMENT DECLARATIONS
*/
/*
                    VALUES GLOBAL TO rsexec_server_ (OVER ALL LISTENING COMMAND LINKS)
*/

          declare
                    next_link_identifier                    fixed bin(35) init(0) static internal,
                    next_listener_id                        fixed bin(35) init(0) static internal,
                    server_host_id                          fixed bin(16) static internal,
                    server_net_userid                       fixed bin (24) static internal;

/*        protocol types                          */
          declare
                    (GENERAL_PROTOCOL                       initial(1),
                     TENEX_PROTOCOL                         initial(2)
                    )                                       fixed binary(8) internal static;

/*        socket genders                          */
          declare
                    (WRITE init(1),
                     READ  init(2))                         fixed binary(8) internal static;

/*        file transfer modes and types           */
          declare
                    (STREAM init(1),
                     BLOCK  init(2),
                     PAGE   init(3),
                     NASCII init(1),
                     IMAGE  init(2))                        fixed binary(8) internal static;

/*        auxiliary socket usages and states      */
          declare
                    (UNUSED             init(0),
                     ALLOCATED          init(1),
                     CONNECTED          init(2),
                     LINKED             init(3),
                     FILE_TRANSFER      init(4))            fixed binary(8) internal static;


/*
                    VALUES UNIQUE AND AVAILABLE TO EACH INVOCATION OF rsexec_server_
                    (ie., each request stream from a foreign user, implemented as a separate task)


*/

          declare     (
                    server_error_code                       fixed binary(35),
                    this_listener_id                        fixed binary(35),
                    send_error_messages                     bit(1) aligned,
                    protocol                                fixed binary(8),
                    ARPAseg_ptr                             pointer initial (null()),
                    FISH_pointer                            pointer initial (null()),
                    err_code                                fixed binary(35),
                    err_code_17                             fixed bin(17),
                    token                                   char(64) varying,
                    rsexec_error                            char(96),
                    FISH_file_name                          char(40),
                    susr_person_id                          char(23),
                    susr_project_id                         char(12),
                    susr_stream                             pointer,
                    susr_flag                               bit(1) aligned initial ("0"b)
                                                            ) automatic;

          declare
                    susr_error_code aligned automatic fixed binary (35);

          /*
                    NETWORK I/O BUFFERS for each rsexec_server_ invocation
          */

          declare
                    1 output_chars_GENERAL aligned automatic,
                      2 byte_offset     fixed binary (24),
                      2 num_bytes       fixed binary (24),
                      2 workspace aligned,
                        3 byte (0 : 1023) character (1) unaligned;

          declare
                    1 input_chars_GENERAL aligned automatic,
                      2 byte_offset     fixed binary (24),
                      2 num_bytes       fixed binary (24),
                      2 workspace aligned,
                        3 byte (0 : 1023) bit (9) unaligned;

          declare
                    output_string char (1024) defined (output_chars_GENERAL.byte);

          declare
                    1 output_chars_TENEX aligned automatic,
                      2 byte_offset               fixed bin(24),
                      2 num_bytes                 fixed bin(24),
                      2 workspace                 aligned,
                        3 byte(0 : 31)            bit(36) unaligned;

          declare
                    1 input_chars_TENEX aligned automatic,
                      2 byte_offset               fixed bin(24),
                      2 num_bytes                 fixed bin(24),
                      2 workspace                 aligned,
                        3 byte(0 : 31)            bit(36) unaligned;



          /* * * * * INCLUDE FILES * * * * * * * * * * * * */

          % include net_event_template;
          % include rsexec_fish_dcls;
          % include rsexec_sst_dcls;
          % include rsexec_ult_dcls;

          /* A portion of the whotab is included here for use with usinf_proc and link_proc.
             This is the portion of the whotab which exists for each user.
          */

          declare
                    1 whotab_entry based,
                      2 active                    fixed bin,
                      2 person                    char(28) aligned,
                      2 project                   char(28),
                      2 anon                      fixed bin,
                      2 padding                   fixed bin(71),
                      2 timeon                    fixed bin(71),
                      2 units                     fixed bin,
                      2 stby                      fixed bin,
                      2 idcode                    char(4),
                      2 chain                     fixed bin,
                      2 proc_type                 fixed bin,
                      2 group                     char(8),
                      2 pad2                      fixed bin,
                      2 cant_bump_until           fixed bin(71),
                      2 pad1(2)                   fixed bin;


          /* * * * * ENTRY & PROCEDURE DECLARATIONS  * * * */

          declare
                    com_err_ constant entry options (variable),
                    convert_pdp10_bytes_$direct_7_to_9 entry (pointer,pointer,fixed bin(24),fixed bin(24), fixed bin (24), pointer,
                              fixed bin(24),fixed bin(24),fixed bin (24), fixed bin (35)),
                    convert_pdp10_bytes_$direct_9_to_7 entry (pointer,pointer,fixed bin(24),fixed bin(24), fixed bin (24), pointer,
                              fixed bin(24),fixed bin(24),fixed bin (24), fixed bin (35)),
                    cu_$arg_list_ptr constant entry () returns (ptr),
                    cv_dec_check_ entry (char(*),fixed bin) returns (fixed bin(35)),
                    cv_oct_check_ entry (char(*),fixed bin) returns (fixed bin(35)),
                    cu_$gen_call constant entry (entry, ptr),
                    date_time_ constant entry (fixed bin (71), char (*)),
                    get_process_id_ entry returns (bit(36)),
                    hcs_$initiate entry (char(*),char(*),char(*),fixed bin(1), fixed bin(2),ptr,fixed bin(35)),
                    hcs_$set_bc_seg entry (pointer, fixed bin(24), fixed bin(35)),
                    hcs_$wakeup entry (bit(36) aligned,fixed bin(71),fixed bin(71),fixed bin(35)),
                    host_id_$check_id entry (char(*),bit(1),fixed bin(16),bit(1),fixed bin(35)),
                    host_id_$symbol entry (fixed bin(16), char(*), fixed bin(35)),
                    ioa_ constant entry options (variable),
                    ioa_$ioa_switch entry options(variable),
                    ioa_$nnl entry options(variable),
                    ioa_$rsnnl constant entry options (variable),
                    ioa_$rsnpnnl constant entry options (variable),
                    iox_$attach_iocb constant entry (ptr, char (*), fixed bin (35)),
                    iox_$close constant entry (ptr, fixed bin (35)),
                    iox_$control constant entry (ptr, char (*), ptr,fixed binary(35)),
                    iox_$detach_iocb constant entry (ptr, fixed bin (35)),
                    iox_$find_iocb constant entry (char (*), ptr, fixed bin (35)),
                    iox_$get_chars constant entry (ptr, ptr, fixed bin (24), fixed bin (24),fixed binary(35)),
                    iox_$get_line constant entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35)),
                    iox_$open constant entry (ptr, fixed bin (17), bit (1) aligned, fixed bin (35)),
                    iox_$put_chars constant entry (ptr, ptr, fixed bin (24),fixed binary(35)),
                    ipc_$block entry (ptr,ptr,fixed bin(35)),
                    ipc_$create_ev_chn entry (fixed bin(71),fixed bin(35)),
                    ipc_$delete_ev_chn entry (fixed bin(71),fixed bin(35)),
                    net_connect_$complete_connection entry (fixed binary(8),fixed binary(71),fixed binary(71),
                              fixed bin (16), fixed bin (32),bit(36),bit(36),fixed binary(35)),
                    net_connect_$open_connection entry (fixed binary(8), fixed bin (17), fixed bin (16), fixed bin (32), bit(2),
                              fixed binary(17), fixed binary(71), fixed binary(35)),
                    ncp_$get_userid constant entry (fixed bin (24), fixed bin(35)),
                    ncp_$local_host_number constant entry (fixed bin (16), fixed bin (35)),
                    ncp_$attach_socket entry (fixed bin(8),fixed bin(71),bit(36),fixed bin(35)),
                    ncp_$close_connection entry(bit(36),fixed bin(6),fixed bin(35)),
                    ncp_$detach_socket entry (bit(36), fixed bin(35)),
                    ncp_$set_bytesize entry(bit(36),fixed bin(8),fixed bin(35)),
                    net_pin_manager_$allocate_pins constant entry (fixed bin (8), fixed bin (8), fixed bin(35)),
                    net_pin_manager_$free_pins constant entry (fixed bin (8), fixed bin (8), fixed bin(35)),
                    ncp_$passoff_socket entry (bit(36), bit (36) aligned, bit (*), fixed bin(35)),
                    rsexec_ascii_$get_line entry (pointer, pointer, fixed bin(24), bit(1), fixed bin(35)),
                    rsexec_ascii_$send_line entry (pointer, pointer, fixed bin(24), fixed bin(35)),
                    send_message_ entry (char(*),char(*),char(*),fixed binary(35)),
                    set_lock_$lock entry (bit(36) aligned,fixed bin,fixed bin(35)),
                    set_lock_$unlock entry (bit(36) aligned,fixed bin(35)),
                    system_info_$installation_id constant entry (char (*)),
                    system_info_$next_shutdown constant entry (fixed bin (71), char (*), fixed bin (71)),
                    system_info_$sysid constant entry (char (*)),
                    system_info_$users constant entry (fixed bin (17), fixed bin (17), fixed bin (17), fixed bin (17)),
                    unique_chars_ entry (bit(*)) returns (char(15)),
                    who_info_ constant entry (char (*), entry (char (*), ptr), fixed binary(35));

     declare
                    (addr,binary,bit,dimension,divide,hbound,length,null,substr,lbound,
                     translate,unspec,index,mod,fixed,before,ceil)              builtin;

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

          P_error_code = 0;

          tracing = P_info_bits;

          server_error_code = 0;

          on program_interrupt
               goto return_to_caller;

          send_error_messages = "0"b;
          protocol = GENERAL_PROTOCOL;

          susr_stream = null ();

          next_listener_id = next_listener_id + 1;
          this_listener_id = next_listener_id;

          output_chars_GENERAL.num_bytes = 0;
          output_chars_GENERAL.byte_offset = 0;

          input_chars_GENERAL.num_bytes = 0;

          do while ("1"b);
               if protocol = GENERAL_PROTOCOL then do;
                    call rsexec_ascii_$get_line(P_iocb_ptr, addr(input_chars_GENERAL.byte),
                              input_chars_GENERAL.num_bytes, "0"b, server_error_code);
                    if tracing
                    then call ioa_ ("read ^d bytes from input stream.", input_chars_GENERAL.num_bytes);
                    if server_error_code ^= 0 then go to return_to_caller;
                    input_chars_GENERAL.byte_offset = 0;
                    input_chars_GENERAL.byte (input_chars_GENERAL.num_bytes) = ascii_value_$SP;
                    end;

               call decode_command ();
               end;

return_to_caller:
          if tracing
          then call ioa_("T: ^d returning to caller (code = ^w)",this_listener_id, server_error_code);

          P_error_code = server_error_code;

          if susr_stream ^= null ()
          then do;
               call iox_$close (susr_stream, (0));
               call iox_$detach_iocb (susr_stream, (0));
               end;

          do itemp = lbound (server_socket_table, 1) by 1 to hbound (server_socket_table, 1);
               if server_socket_table (itemp).listener_id_no = this_listener_id
               then call free_network_pin (itemp);
               end;

          P_error_code = server_error_code;

/* we really should release all the sockets streams we have attached */
          /* server_error_code must always be set before transfer to
             return_to_caller */

          return;

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

initialize_the_goodies: entry;
          declare
                    itemp               fixed binary(8);

          call ncp_$local_host_number (server_host_id, err_code);
          if err_code ^= 0 then return;

          call ncp_$get_userid(server_net_userid,err_code);
          if err_code ^= 0 then return;

          do itemp = 0 to 255;
                    server_socket_table(itemp).link_segment_ptr = null();
                    server_socket_table(itemp).socket_usage = UNUSED;
                    server_socket_table(itemp).unused_brother = -1;
                    server_socket_table(itemp).connection_channel,
                    server_socket_table(itemp).link_subscript_or_mode,
                    server_socket_table(itemp).type_for_transfer,
                    server_socket_table(itemp).listener_id_no = 0;
                    server_socket_table(itemp).ncp_index,
                    server_socket_table(itemp).foreign_socket_id = "0"b;
                    end;

          return;

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

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

get_token:
          procedure (p_token);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_token character (*) varying
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

          declare
                    char_indx           fixed binary (24),
                    done                bit(1),
                    char_buffer         char(5),
                    found_delim         bit (1),
                    temp_char           character (1);

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

                                                  /* Remember that all do loop extents and increments are     */
                                                  /* evaluated before the loop is entered           */

          p_token = "";

          if protocol = TENEX_PROTOCOL
          then do;                                          /* for TENEX ASCIX strings                        */
               done = "0"b;
               call get_TENEX_line(0);
               do while (^ done);
                    call convert_pdp10_bytes_$direct_7_to_9 (null (),
                              addr (input_chars_TENEX.byte (input_chars_TENEX.byte_offset)), 0, 5, (0),
                              addr (char_buffer), 0, length (char_buffer) ,(0), (0));

                    input_chars_TENEX.byte_offset = input_chars_TENEX.byte_offset + 1;

                    do char_indx = 1 to 5;
                         if unspec (substr (char_buffer, char_indx, 1)) = (9)"0"b
                         then do;
                              done = "1"b;
                              go to loop_end;
                              end;
                         else if substr (char_buffer, char_indx, 1) = " "
                              then go to loop_end;
                              else p_token = p_token || substr (char_buffer, char_indx, 1);
                         end;

loop_end:
                    end;

               return;
               end;

          /*        HERE FOR GENERAL PROTOCOL ASCII COMMANDS AND STRINGS        */

          found_delim = "1"b;                               /* pretend that we have found a space             */
          do char_indx = input_chars_GENERAL.byte_offset by 1 to input_chars_GENERAL.byte_offset + input_chars_GENERAL.num_bytes - 1
                    while (found_delim);
               if input_chars_GENERAL.byte (char_indx) ^= ascii_value_$SP
               then found_delim = "0"b;
               else do;
                    input_chars_GENERAL.num_bytes = input_chars_GENERAL.num_bytes - 1;
                    input_chars_GENERAL.byte_offset = input_chars_GENERAL.byte_offset + 1;
                    end;
               end;

          found_delim = "0"b;
          do char_indx = input_chars_GENERAL.byte_offset by 1 to input_chars_GENERAL.byte_offset + input_chars_GENERAL.num_bytes - 1
                    while (^ found_delim);
               if input_chars_GENERAL.byte (char_indx) = ascii_value_$SP
               then found_delim = "1"b;
               else do;
                    unspec (temp_char) = input_chars_GENERAL.byte (char_indx);
                    p_token = p_token || temp_char;
                    input_chars_GENERAL.num_bytes = input_chars_GENERAL.num_bytes - 1;
                    input_chars_GENERAL.byte_offset = input_chars_GENERAL.byte_offset + 1;
                    end;
               end;

          if tracing
          then call ioa_ ("T: ^d token is ^a (length ^d)", this_listener_id, p_token, length (p_token));

          return;

end get_token;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

get_TENEX_line:
          procedure(number_of_words);

/* Gets number_of_words from the connection except if
   number_of_words is 0 in which case an asciz string is retrieved. */

          declare
                    i                   fixed bin(17),
                    number_of_words     fixed bin(24),
                    more_words          bit(1) init("1"b);

          input_chars_TENEX.num_bytes,
          input_chars_TENEX.byte_offset = 0;

          if number_of_words > 0
          then do;

                    call iox_$get_chars(P_iocb_ptr,addr(input_chars_TENEX.byte),
                              number_of_words,(0),server_error_code);
                    if server_error_code ^= 0
                    then goto return_to_caller;
                    input_chars_TENEX.num_bytes = number_of_words;
                    return;
                    end;

          do while(more_words);

          call iox_$get_chars(P_iocb_ptr,addr (input_chars_TENEX.byte(input_chars_TENEX.num_bytes)),
                    (1),(0),server_error_code);
          input_chars_TENEX.num_bytes = input_chars_TENEX.num_bytes + 1;

          if ^ (server_error_code = 0 | server_error_code = error_table_$end_of_info | server_error_code =
                    error_table_$short_record) then go to return_to_caller;

          do i = 0 to 4;
          if substr(input_chars_TENEX.byte(input_chars_TENEX.num_bytes - 1),i * 7 + 1,7) = (7)"0"b
          then more_words = "0"b;
          end;
          end;

          if tracing then do;
                    call ioa_$nnl("listener_id ^d   ",this_listener_id);
                    do i = 1 to input_chars_TENEX.num_bytes;
                              call ioa_$nnl("^w ",binary(input_chars_TENEX.byte(i - 1),35));
                              if mod(i,4) = 3 then call ioa_("^/");
                              end;
                    call ioa_("^/");
                    end;

          return;

end       get_TENEX_line;

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

get_TENEX_word:
          procedure() returns (bit(36));

          declare
                    next_byte           bit(36);

          call get_TENEX_line(1);

          next_byte = input_chars_TENEX.byte(input_chars_TENEX.byte_offset);
          input_chars_TENEX.byte_offset = input_chars_TENEX.byte_offset + 1;

          return(next_byte);

end get_TENEX_word;

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

send_line:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

          /* * * * * * * * * * * * * * * * * * * * * * * * */
/* would be nice to trace this */


          if protocol = TENEX_PROTOCOL then do;
                    call iox_$put_chars(P_iocb_ptr,addr(output_chars_TENEX.byte),output_chars_TENEX.num_bytes,
                              server_error_code);
                    if server_error_code ^= 0 then go to return_to_caller;

                    output_chars_TENEX.byte_offset = 0;
                    output_chars_TENEX.num_bytes = 0;

                    return;
                    end;

          /*        HERE FOR GENERAL PROTOCOL     */

          call rsexec_ascii_$send_line(P_iocb_ptr, addr(output_chars_GENERAL.byte),
                    output_chars_GENERAL.num_bytes, server_error_code);
          if server_error_code ^= 0 then go to return_to_caller;
          output_chars_GENERAL.num_bytes = 0;

          return;

end send_line;

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

pos_ack:
          procedure ();

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

          if tracing
          then call ioa_ ("pos ack");

          if protocol = GENERAL_PROTOCOL then do;
                    call ioa_$rsnpnnl ("+^/@", output_string, output_chars_GENERAL.num_bytes);
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    output_chars_TENEX.byte(0) = (36)"1"b;
                    output_chars_TENEX.num_bytes = 1;
                    output_chars_TENEX.byte_offset = 0;
                    end;

          call send_line ();

          return;

end pos_ack;

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

neg_ack:
          procedure (message_number, message_text);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

          declare
                    (message_number     fixed binary(17),
                     message_text       char(*))            parameter;

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

          if tracing
          then call ioa_ ("neg ack:  ^d ^a", message_number, message_text);

          if protocol = GENERAL_PROTOCOL then do;
                    if send_error_messages
                    then call ioa_$rsnpnnl ("^d ^a^/@", output_string, output_chars_GENERAL.num_bytes, message_number, message_text);
                    else call ioa_$rsnpnnl ("^d^/@", output_string, output_chars_GENERAL.num_bytes, message_number);
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    output_chars_TENEX.byte_offset = 0;
                    output_chars_TENEX.num_bytes = 1;
                    output_chars_TENEX.byte(0) = (19)"1"b || bit(message_number,17);
                    end;

          call send_line ();

          return;

end neg_ack;

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

decode_command:
          procedure ();

/*
          Program by Gerard J. Rudisin

          This procedure is the command interpreter for RSEXEC
          commands. Most commands are executed by calling appropriate
          subroutines. The file system commands are executed by
          issuing a wakeup to the rsexec_file_server in another
          process. Certain commands require special processing upon
          return from their execution.

*/


          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

          declare
                    command_string      char(5),
                    command             char(5) varying;

          declare
                    temp_bit            bit(5) unaligned,
                    temp1               fixed binary(17),
                    temp2     fixed bin(17),
                    code                fixed bin(35),
                    num_TENEX_ascii     fixed binary(24);

          declare
                    1 wait_list aligned,
                      2 count           fixed binary(17) init(1),
                      2 event_channel   fixed bin(71);

          declare
                    1 event_info aligned automatic like event_message_template;

          /* * * * * * END OF DECLARATIONS * * * * * */


          /*        FIND the COMMAND    */

          if protocol = GENERAL_PROTOCOL then do;
                    call get_token (token);

                    if length(token) > 5 then do;
                              call neg_ack(-10,"COMMAND TOO LONG");
                              return;
                              end;

                    command_string = token;

                    end;

             else if protocol = TENEX_PROTOCOL then do;
                    command_string = "     ";
                    call get_TENEX_line(1);

                    code = binary(input_chars_TENEX.byte(input_chars_TENEX.byte_offset),35);
                    if code = -1 then do;
                              command = "+";
                              go to check_susr_validity;
                              end;
                       else if code = -4 then do;
                              command = "-";
                              go to check_susr_validity;
                              end;

                    call convert_pdp10_bytes_$direct_7_to_9 (null(),
                              addr(input_chars_TENEX.byte(input_chars_TENEX.byte_offset)),0,5,(0),
                              addr(command_string),0,length(command_string),num_TENEX_ascii, (0));

                    input_chars_TENEX.byte_offset = input_chars_TENEX.byte_offset + 1;

                    do temp1 = 1 to 5;
                              if unspec(substr(command_string,temp1,1)) = "000000000"b then
                                        substr(command_string,temp1,1) = " ";
                              end;

                    end;

          command_string = translate(command_string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz");

          if protocol = GENERAL_PROTOCOL then command = substr(command_string,1,length(token));
             else if protocol = TENEX_PROTOCOL then if index(command_string," ") ^= 0 then
                     command = before(command_string," ");
                     else command = command_string;

          if tracing then call ioa_("T: ^d command is ^a ",this_listener_id,command);


          if command = "" then do;
                    call pos_ack ();
                    return;
                    end;

          if command = "NOOP" | command = "NO-OP" then do;
                    call pos_ack ();
                    return;
                    end;

          if command = "ERSTR" then do;
                    send_error_messages = ^ send_error_messages;
                    call pos_ack ();
                    return;
                    end;

          if command = "QUIT" then do;
                    server_error_code = 0;
                    if susr_flag then do;
                              call ioa_$ioa_switch(susr_stream,"^a","@logout");
                              call iox_$close (susr_stream, (0));
                              call iox_$detach_iocb (susr_stream, (0));
                              call hcs_$set_bc_seg(FISH_pointer, 0, (0));
                              FISH_pointer = null();
                              susr_flag = "0"b;
                              end;

                    call break_proc(-1,err_code_17);
                    if err_code_17 ^= 0 then do;
                              go to return_to_caller;
                              end;

                    call clse_proc(-2,err_code_17);
                    if err_code_17 ^= 0 then do;
                              go to return_to_caller;
                              end;

                    go to return_to_caller;
                    end;

          if command = "SSINF" then do;
                    call ssinf_proc ();
                    return;
                    end;

          if command = "USINF" then do;
                    call usinf_proc ();
                    return;
                    end;

          if command = "PTCL" then do;
                    call ptcl_proc();
                    return;
                    end;

          if command = "AUXS" then do;
                    call auxs_proc();
                    return;
                    end;

          if command = "CONN" then do;
                    call conn_proc();
                    return;
                    end;

          if command = "CLSE" then do;
                    call clse_proc(-1,err_code_17);
                    return;
                    end;

          if command = "LINK" then do;
                    call link_proc();
                    return;
                    end;

          if command = "BREAK" then do;
                    if protocol = TENEX_PROTOCOL then go to no_command;
                    call break_proc(0,err_code_17);
                    return;
                    end;

          if command = "SUSR" then do;
                    call susr_proc();
                    return;
                    end;

          if command = "TYPE" then do;
                    call mode_proc(("0"b));
                    return;
                    end;

          if command = "MODE" then do;
                    call mode_proc(("1"b));
                    return;
                    end;

          /* If file command, see if a valid SUSR has been carried out */

check_susr_validity:
          if index ("SDIR DEL REN APPN COPY + - DRINF FLINF RETRV STORE NAPN SACT",command) = 0 then go to other_commands;
             else if ^susr_flag then do;
                    call neg_ack(-30,"NO SUSR COMMAND SO FAR EXECUTED");
                    return;
                    end;

          if command = "SACT" then do;
                    /*        ignore the account number if one is supplied by foreign programs      */
                    call get_token (token);
                    call pos_ack();
                    return;
                    end;

          if command = "SDIR" then do;
                    do temp1 = 1 to 2;
                              call get_token (token);
                              parameter(temp1) = token;
                              end;
                    request = 1;
                    go to signal_file_server;
                    end;

          if command = "DEL" then do;
                    call get_token (token);
                    parameter(1) = token;
                    request = 2;
                    go to signal_file_server;
                    end;

          if command = "REN" then do;
                    do temp1 = 1 to 2;
                              call get_token (token);
                              parameter(temp1) = token;
                              end;
                    request = 3;
                    go to signal_file_server;
                    end;

          if command = "APPN" then do;
                    do temp1 = 1 to 2;
                              call get_token (token);
                              parameter(temp1) = token;
                              end;
                    request = 5;
                    go to signal_file_server;
                    end;

          if command = "COPY" then do;
                    do temp1 = 1 to 2;
                              call get_token (token);
                              parameter(temp1) = token;
                              end;
                    request = 4;
                    go to signal_file_server;
                    end;

          if command = "DRINF" then do;
                    call get_token (token);
                    parameter(1) = token;
                    request = 9;
                    go to signal_file_server;
                    end;

          if command = "FLINF" then do;
                    call get_token (token);
                    parameter(1) = token;
                    request = 12;
                    go to signal_file_server;
                    end;

          if command = "RETRV" then do;
                    call transfer_proc(1,err_code_17);
                    if err_code_17 ^= 0 then return;
                    request = 6;
                    go to signal_file_server;
                    end;

          if command = "STORE" then do;
                    call transfer_proc(2,err_code_17);
                    if err_code_17 ^= 0 then return;
                    request = 7;
                    go to signal_file_server;
                    end;

          if command = "NAPN" then do;
                    call transfer_proc(3,err_code_17);
                    if err_code_17 ^= 0 then return;
                    request = 8;
                    go to signal_file_server;
                    end;

          if command = "+" then do;
                    request = 10;
                    go to signal_file_server;
                    end;

          if command = "-" then do;
                    request = 11;
                    go to signal_file_server;
                    end;

other_commands:
          call neg_ack(-10,"COMMAND NOT RECOGNIZED OR NOT IMPLEMENTED: " || command);
          return;

no_command:
          call neg_ack(-777,"COMMAND NOT IMPLEMENTED IN TENEX PROTOCOL");
          return;


/*        wakeup the file server in the process of the last SUSR useridentifier */

signal_file_server:

          call hcs_$wakeup(file_server_proc_id,file_server_channel,(0),code);
          if code ^= 0 then do;

file_ipc_error:
                    call neg_ack(-650,"SUSR USER LOGGED OUT BY ERROR");
                    return;
                    end;

          event_channel = system_server_channel;
          call ipc_$block(addr(wait_list),addr(event_info),code);
          if code ^= 0 then go to file_ipc_error;

          /* responses needing special processing (DRINF, FLINF) go here */

          if request = 9 | request = 12 then do;            /* DRINF or FLINF */
                    if return_file_code = 0 then call pos_ack();
                       else do;
                              call neg_ack(return_file_code,return_file_message);
                              return;
                              end;

                    do temp1 = 1 to numeric_parameter(1);
                              if protocol = GENERAL_PROTOCOL then do;
                                        temp_bit = file_information_block(temp1).access_privileges;
                                        token = "";
                                        if substr(temp_bit,2,1) then token = token || "r";
                                           else token = token || " ";

                                        if substr(temp_bit,3,1) then token = token || "e";
                                           else token = token || " ";

                                        if substr(temp_bit,4,1) then token = token || "w";
                                           else token = token || " ";

                                        if token = "   " then token = "null";

                                        call ioa_$rsnpnnl("   ^a^-^d^-^a^/",output_string,output_chars_GENERAL.
                                                  num_bytes,token,file_information_block(temp1).number_of_records,
                                                  file_information_block(temp1).branch_name);

                                        call send_line();
                                        end;
                                 else if protocol = TENEX_PROTOCOL then do;
                                        call convert_pdp10_bytes_$direct_9_to_7(null(),
                                                  addr(file_information_block(temp1).branch_name),0,
                                                  length(file_information_block(temp1).branch_name), (0),
                                                  addr(output_chars_TENEX.byte),0,dimension(
                                                  output_chars_TENEX.byte,1),num_TENEX_ascii, (0));
                              temp2 = index(file_information_block(temp1).branch_name," ");
                              if temp2 = 0
                              then temp2 = length(file_information_block(temp1).branch_name) + 1;

                              num_TENEX_ascii = ceil(temp2/5);

/* temp2 - 5 * num_TENEX_ascii is the position of the first character that
   has to be zeroed for asciz format.   */

          substr(output_chars_TENEX.byte(num_TENEX_ascii - 1),(temp2 - 5*(num_TENEX_ascii - 1))*7 - 6,36) = "0"b;

                                        temp_bit = file_information_block(temp1).access_privileges;
                                        output_chars_TENEX.byte(num_TENEX_ascii) = substr(temp_bit,2,1) ||
                                                  substr(temp_bit,4,1) || substr(temp_bit,3,1) ||
                                                  substr(temp_bit,5,1) || (32)"0"b;

                                        output_chars_TENEX.byte(num_TENEX_ascii + 1) = (11)"0"b || "1"b || (6)"0"b ||
                                                  bit(binary(file_information_block(temp1).
                                                  number_of_records * 2,17));

                                        output_chars_TENEX.byte(num_TENEX_ascii + 2) = bit(binary(file_information_block(
                                                  temp1).bit_count,35));

                                        output_chars_TENEX.byte(num_TENEX_ascii + 3),
                                        output_chars_TENEX.byte(num_TENEX_ascii + 4),
                                        output_chars_TENEX.byte(num_TENEX_ascii + 5) = "0"b;

                                        output_chars_TENEX.byte_offset = 0;
                                        output_chars_TENEX.num_bytes = num_TENEX_ascii + 6;

                                        call send_line();
                                        end;

                              end;

                    call pos_ack();
                    return;
                    end;


          if return_file_code > 0 then call neg_ack(return_file_code," ");
             else if return_file_code = 0 then call pos_ack();
                     else if return_file_code < 0 then call neg_ack(return_file_code,return_file_message);

          return;


end decode_command;

/* * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
auxs_proc:
          procedure();

/*
          Program by Gerard J. Rudisin

          RSEXEC procedure to handle requests for the allocation of an
          auxiliary socket. Request format is:

                    AUXS (S or R) SIZE USER HANDLE

          where S or R is a required statement of socket gender
          (send or receive), SIZE specifies the byte size of the socket, and
          USER HANDLE is an optional user supplied handle which the server must
          use in all subsequent communication with the foreign user. This
          argument is currently ignored as it is never used in the current protocol.

*/

          declare
                    (socket_type init(0),
                    err_code
                    )                   fixed binary(17),
                    socket_size         fixed bin(8),
                    code                fixed binary(35);

          declare
                    (first_pin,
                    keep_socket,
                    discard_socket
                    )                   fixed binary(8),
                    channel             fixed binary(71),
                    wait_channel        fixed binary(71),
                    conn_type           bit(2) unaligned,
                    temp_socket         fixed bin(35),
                    hold_ncp_index      bit(36);

          /* * * * * * END OF DECLARATIONS * * * * * */


          if protocol = TENEX_PROTOCOL then do;
                    unspec(code) = get_TENEX_word();
                    if code = 0
                    then socket_type = READ;
                    else if code = -1
                         then socket_type = WRITE;
                         else do;
                              /* dispose of next item in buffer first */
                                        unspec(code) = get_TENEX_word();
                                        go to bad_gender;
                                        end;

                    unspec(code) = get_TENEX_word();
                    socket_size = code;
                    if (socket_size ^= 8 & socket_size ^= 32 & socket_size ^= 36)
                    then go to bad_size;
                    end;
          else do;
                              /*        Decode socket type            */
               call get_token (token);
               if token = "S"
               then socket_type = WRITE;
               else if token = "R"
                    then socket_type = READ;
                    else do;
bad_gender:
                              err_code = 220;
                              rsexec_error = "UNKNOWN SOCKET GENDER SPECIFICATION";
                              go to auxs_errors;
                              end;

/*        Decode socket size            */
               call get_token (token);

               if token = "8"
               then socket_size = 8;
               else if token = "32"
                    then socket_size = 32;
                    else if token = "36"
                         then socket_size = 36;
                             else do;

bad_size:
                                        err_code = 221;
                                        rsexec_error = "ILLEGAL BYTE SIZE SPECIFICATION";
                                        go to auxs_errors;
                                        end;

               end;

/*        Since pin numbers are always allocated in pairs,
          get a pair and save the one of appropriate gender,
          "discarding" the other
*/

          call net_pin_manager_$allocate_pins(2,first_pin,code);
          if code ^= 0 then do;
                    err_code = 21;
                    rsexec_error = "NO MORE SOCKETS ARE AVAILABLE AT THIS TIME";
                    go to auxs_errors;
                    end;

          if socket_type = READ then do;
                    keep_socket = first_pin;
                    discard_socket = first_pin + 1;
                    end;
             else do;
                    keep_socket = first_pin + 1;
                    discard_socket = first_pin;
                    end;

          call ipc_$create_ev_chn(channel,code);
          if code ^= 0 then do;
                    err_code = 21;
                    rsexec_error = "CANNOT ALLOCATE A NEW SOCKET";
                    go to auxs_errors;
                    end;

          call ncp_$attach_socket(keep_socket,channel,hold_ncp_index,code);
          if code ^= 0 then do;
                    err_code = 21;
                    rsexec_error = "CANNOT ACTIVATE SOCKET";
                    go to auxs_errors;
                    end;

          server_socket_table(keep_socket).socket_usage = ALLOCATED;
          server_socket_table(keep_socket).listener_id_no = this_listener_id;
          server_socket_table(keep_socket).gender = socket_type;
          server_socket_table(keep_socket).byte_size = socket_size;
          server_socket_table(keep_socket).unused_brother = discard_socket;
          server_socket_table(keep_socket).ncp_index = hold_ncp_index;
          server_socket_table(keep_socket).event_channel = channel;


          if socket_size ^= 8 then do;
                    call ncp_$set_bytesize(hold_ncp_index,socket_size,code);
                    if code ^= 0 then do;
                              err_code = 221;
                              rsexec_error = "CANNOT SET SOCKET TO DESIRED SIZE";
                              go to auxs_errors;
                              end;
                    end;

/*        Send response                 */

          temp_socket = server_net_userid * 256 + binary(keep_socket,8);

          call ipc_$create_ev_chn(wait_channel, code);
          if code ^= 0 then do;
                    err_code = 777;
                    go to auxs_errors;
                    end;

          server_socket_table(keep_socket).connection_channel = wait_channel;
          if server_socket_table(keep_socket).gender = WRITE then conn_type = "01"b;
             else conn_type = "10"b;

          call net_connect_$open_connection(first_pin, 12, -1, -1, conn_type, 120, wait_channel, code);
          if code ^= 0 then do;
                    err_code = 777;
                    go to auxs_errors;
                    end;

          if protocol = GENERAL_PROTOCOL then do;
                    call ioa_$rsnpnnl("+^o ^d+^/@",output_string,output_chars_GENERAL.num_bytes,
                              temp_socket,keep_socket);
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    output_chars_TENEX.byte(0) = (36)"1"b;
                    output_chars_TENEX.byte(1) = unspec(temp_socket);
                    output_chars_TENEX.byte(2) = unspec(keep_socket);
                    output_chars_TENEX.byte_offset = 0;
                    output_chars_TENEX.num_bytes = 3;
                    end;

          call send_line();
          return;

auxs_errors:
          call neg_ack(-err_code,rsexec_error);
          return;

end       auxs_proc;

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

conn_proc:
          procedure();

/*
          Program by Gerard J. Rudisin

          RSEXEC procedure to handle connection requests for a socket
          previously allocated via AUXS. Request format is:

                    CONN M H R

          where M is the handle of the previously allocated socket,
          H is the octal socket number of the foreign socket to which
          connection is to be made, and R is an optional specification
          of a host for a remote connection.

*/
          declare
                    foreign_host_id     fixed binary(16),
                    pin_number          fixed binary(8),
                    lower_pin           fixed binary(8),
                    (conv_code,
                    err_code
                    )                   fixed bin(17),
                    socket_number       fixed bin(32),
                    code                fixed binary(35),
                    temp_string         char(32);

          declare
                    conn_type           bit(2) unaligned,
                    correct_for_socket  bit(41);
          declare
                    1 wait_list aligned,
                      2 count           fixed binary init(1),
                      2 event_channel   fixed binary(71);
          declare
                    1 event_information aligned automatic like event_message_template;

          /* * * * * * END OF DECLARATIONS * * * * * */


          if protocol = TENEX_PROTOCOL then do;
                    unspec(code) = get_TENEX_word();
                    pin_number = code;
                    unspec(code) = get_TENEX_word();
                    socket_number = code;
                    unspec(code) = get_TENEX_word();
                    if code = 0
                    then foreign_host_id = P_foreign_host;
                    else foreign_host_id = code;
                    end;
             else if protocol = GENERAL_PROTOCOL then do;
                    call get_token (token);
                    temp_string = token;
                    pin_number = cv_dec_check_(temp_string,conv_code);
                    if conv_code ^= 0 then do;
                              err_code = 11;
                              rsexec_error = "ILLEGAL CHARACTER IN HANDLE";
                              go to conn_errors;
                              end;
                    end;

          if pin_number < lbound(server_socket_table,1) |
             pin_number > hbound(server_socket_table,1) then do;
                    err_code = 260;
                    rsexec_error = "NO SUCH HANDLE EXISTS";
                    go to conn_errors;
                    end;

          if server_socket_table(pin_number).socket_usage = UNUSED |
             server_socket_table(pin_number).listener_id_no ^= this_listener_id then do;
                    err_code = 20;
                    rsexec_error = "YOU DO NOT OWN OR DID NOT ALLOCATE THIS SOCKET";
                    go to conn_errors;
                    end;

          if server_socket_table(pin_number).socket_usage ^= ALLOCATED then do;
                    err_code = 271;
                    rsexec_error = "SOCKET ALREADY CONNECTED OR IN USE. MUST CLOSE TO RE-USE";
                    go to conn_errors;
                    end;


          if protocol = TENEX_PROTOCOL then do;
                    call host_id_$symbol(foreign_host_id,temp_string,code);
                    if code ^= 0 then go to bad_foreign_host;
                    end;
          else do;
               call get_token (token);
               temp_string = token;
               socket_number = cv_oct_check_(temp_string,conv_code);
               if conv_code ^= 0 then do;
                    err_code = 11;
                    rsexec_error = "ILLEGAL CHARACTER IN SOCKET NUMBER";
                    go to conn_errors;
                    end;

               call get_token (token);
               if token = ""
               then foreign_host_id = P_foreign_host;
               else do;
                    temp_string = token;
                    call host_id_$check_id(temp_string,"1"b,foreign_host_id,"0"b,code);
                    if code ^= 0 then do;

bad_foreign_host:
                              err_code = 25;
                              rsexec_error = "NO SUCH REMOTE HOST";
                              go to conn_errors;
                              end;
                    end;

               end;

          correct_for_socket = bit(binary(foreign_host_id,9)) || bit(binary(socket_number,32));

          lower_pin = pin_number - mod(pin_number,2);
          if server_socket_table(pin_number).gender = WRITE
          then conn_type = "01"b;
          else /* READ */ conn_type = "10"b;

          event_channel = server_socket_table(pin_number).connection_channel;

          call ipc_$block(addr(wait_list),addr(event_information),code);
          if code ^= 0 then do;
                    err_code = 272;
                    rsexec_error = "SERVER ERROR IN CONN_PROC";
                    go to conn_errors;
                    end;

          call ipc_$delete_ev_chn(event_channel,code);
          server_socket_table(pin_number).connection_channel = 0;

          if conn_type = "10"b
          then call net_connect_$complete_connection(lower_pin,
                    server_socket_table(pin_number).event_channel,0,(-1),(-1),
                    server_socket_table(pin_number).ncp_index,(""b),code);
          else call net_connect_$complete_connection(lower_pin,
                    0,server_socket_table(pin_number).event_channel,(-1),(-1),(""b),
                    server_socket_table(pin_number).ncp_index,code);

          if code ^= 0 then do;
                    err_code = 24;
                    rsexec_error = "ATTEMPT TO CONCLUDE CONNECTION FAILED";
                    go to conn_errors;
                    end;

          server_socket_table(pin_number).socket_usage = CONNECTED;
          server_socket_table(pin_number).foreign_socket_id = correct_for_socket;
          call pos_ack();
          return;

conn_errors:

          call neg_ack(-err_code,rsexec_error);
          return;

end conn_proc;

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

link_proc:
          procedure();

/*

          Program by Gerard J. Rudisin

          RSEXEC server subroutine to handle requests for links.
          Command format is:    LINK M N TARGET

          where M and N are handles for sockets, and
          target is the user identifier of the form user.project

*/
          declare
                    (temp,
                    user_count          init(0),
                    err_code,
                    this_link)          fixed binary(17),
                    message             fixed binary(71),
                    code                fixed binary(35),
                    message_bit         bit(72)   init("0"b),
                    temp_bit            bit(36);

          declare
                    temp_string         char(32),
                    project_id          char(12),
                    user_id             char(23),
                    ARPAnet_msgs_name   char(34),
                    dirname             char(168);
          declare
                    (pin_number,
                    send_pin,
                    receive_pin
                    )                   fixed binary(35);


          /* * * * * * END OF DECLARATIONS * * * * * */


          if protocol = TENEX_PROTOCOL then do;
                    unspec(code) = get_TENEX_word();
                    pin_number = code;
                    unspec(code) = get_TENEX_word();
                    send_pin = code;
                    end;
          else do;
               call get_token (token);
               temp_string = token;
               pin_number = cv_dec_check_(temp_string,err_code);
               if err_code ^= 0 then do;

error_1:
                    err_code = 11;
                    rsexec_error = "ILLEGAL CHARACTER IN HANDLE";
                    go to link_errors;
                    end;

               call get_token (token);
               temp_string = token;
               send_pin = cv_dec_check_(temp_string,err_code);
               if err_code ^= 0 then go to error_1;
               end;

          if pin_number > hbound(server_socket_table,1) | send_pin > hbound(server_socket_table,1) |
             pin_number < lbound(server_socket_table,1) | send_pin < lbound(server_socket_table,1) then do;
                    err_code = 260;
                    rsexec_error = "NO SUCH HANDLE EXISTS";
                    go to link_errors;
                    end;

          if server_socket_table(pin_number).listener_id_no ^= this_listener_id |
             server_socket_table(send_pin).listener_id_no ^= this_listener_id then do;
                    err_code = 20;
                    rsexec_error = "ONE OR BOTH SOCKETS ARE NOT YOURS";
                    go to link_errors;
                    end;

          if server_socket_table(pin_number).socket_usage ^= CONNECTED |
             server_socket_table(send_pin).socket_usage ^= CONNECTED then do;
                    err_code = 271;
                    rsexec_error = "ONE OR BOTH OF THESE SOCKETS ARE IN USE OR NOT CONNECTED";
                    go to link_errors;
                    end;

          if mod(pin_number,2) = 0 then do;
                    receive_pin = pin_number;
                    end;
             else do;
                    receive_pin = send_pin;
                    send_pin = pin_number;
                    end;

          if mod(send_pin,2) = mod(receive_pin,2) then do;
                    err_code = 651;
                    rsexec_error = "MUST HAVE A READ AND A WRITE SOCKET FOR LINK";
                    go to link_errors;
                    end;

          if server_socket_table(receive_pin).byte_size ^= 8 |
             server_socket_table(send_pin).byte_size ^= 8 then do;
                    err_code = 652;
                    rsexec_error = "LINK SOCKETS MUST BE 8 BIT BYTES";
                    go to link_errors;
                    end;

          call get_token (token);

          call who_info_((token), who_info_handler, code);
          if user_count = 0 then do;
                    err_code = 602;
                    rsexec_error = "USER NOT LOGGED IN";
                    go to link_errors;
                    end;

/*        Otherwise, user is logged in */

          call ioa_$rsnnl(">udd>^a>^a",dirname,temp,project_id,user_id);
          temp = index(user_id," ") - 1;
          ARPAnet_msgs_name = substr(user_id,1,temp)||".ARPAnet_msgs";
          call hcs_$initiate(dirname,ARPAnet_msgs_name,"",0b,1b,ARPAseg_ptr,code);

          if ARPAseg_ptr = null then do;

signal_message:
/*                    call send_message_(user_id,project_id,
                    "Attempt to link from ARPA network. " || "
" ||
                    "To accept links, execute accept_rsexec_links", (0));   */
                    err_code = 63;
                    rsexec_error = "USER NOT ACCEPTING LINKS. TRY AGAIN LATER";
                    go to link_errors;
                    end;

          call set_lock_$lock(lock,20,code);
          if code = error_table_$invalid_lock_reset then do;
                    call set_lock_$unlock(lock,code);
                    go to signal_message;
                    end;

          if code = error_table_$lock_wait_time_exceeded then do;
                    err_code = 63;
                    rsexec_error = "COULD NOT OPEN LINK; USER PROCESS MAY HAVE BEEN TERMINATED";
                    go to link_errors;
                    end;

          if number_of_links = 5 then do;
                    call set_lock_$unlock(lock,code);
                    err_code = 63;
                    rsexec_error = "USER ALREADY HAS MAXIMUM NUMBER OF LINKS IN PROGRESS";
                    go to link_errors;
                    end;

          do temp = 1 to 5;
                    if links(temp).link_identifier = 0 then go to got_one;
                    end;
got_one:
          this_link = temp;
          number_of_links = number_of_links + 1;
          call set_lock_$unlock(lock,code);

          next_link_identifier = next_link_identifier + 1;
          links(this_link).link_identifier = next_link_identifier;
          links(this_link).foreign_host_number = P_foreign_host;
          temp_bit,links(this_link).receive_socket.receive_socket_index =
                    server_socket_table(receive_pin).ncp_index;

          call ncp_$passoff_socket (temp_bit, linkees_process_id, ""b, code);
          if code ^= 0 then do;

passoff_error:
                    err_code = 275;
                    rsexec_error = "COULD NOT PASS OFF SOCKET TO USER. LINK FAILED";
                    go to link_errors;
                    end;

          temp_bit,links(this_link).send_socket.send_socket_index =
                    server_socket_table(send_pin).ncp_index;
          call ncp_$passoff_socket (temp_bit, linkees_process_id, ""b, code);
          if code ^=0 then go to passoff_error;


          links(this_link).listener_id = this_listener_id;
          links(this_link).receive_socket.receive_pin_no = receive_pin;
          links(this_link).send_socket.send_pin_no = send_pin;
          links(this_link).receive_socket.receive_foreign_socket =
                    server_socket_table(receive_pin).foreign_socket_id;
          links(this_link).send_socket.send_foreign_socket =
                    server_socket_table(send_pin).foreign_socket_id;

          servers_network_uid = binary (server_net_userid, 24);
          substr(message_bit, 1, 18) = bit(binary(this_link, 18));
          unspec(message) = message_bit;
          call hcs_$wakeup(linkees_process_id,link_notice_channel,message,code);
          if code ^= 0 then do;
                    links(this_link).link_identifier = 0;
                    go to signal_message;
                    end;

          server_socket_table(send_pin).socket_usage,
          server_socket_table(receive_pin).socket_usage = LINKED;
          server_socket_table(send_pin).link_segment_ptr,
          server_socket_table(receive_pin).link_segment_ptr = ARPAseg_ptr;
          server_socket_table(send_pin).link_subscript_or_mode,
          server_socket_table(receive_pin).link_subscript_or_mode = this_link;


          call pos_ack();
          return;

link_errors:
          call neg_ack(-err_code,rsexec_error);
          return;
/* * * * * * * * * * * * * * * * * * * * */
who_info_handler:
          procedure(login_name,entry_pointer);

          declare
                    (login_name char(*),
                     entry_pointer pointer
                    )                   parameter;

          if entry_pointer -> whotab_entry.proc_type ^= 1
          then return;

          user_count = 1;

          user_id = entry_pointer -> whotab_entry.person;
          project_id = entry_pointer -> whotab_entry.project;

          return;

end who_info_handler;
/* * * * * * * * * * * * * * * * * * * * */

          end link_proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
clse_proc:
          procedure(supplied_handle,return_code);

/*

          Program by Gerard J. Rudisin

          RSEXEC server procedure to process close commands, of the form

                    CLSE N (HOLD)

          where N is the handle of a previously allocated socket, and
          HOLD is an optional arbitrary string. If N is not given, all
          connections except those used in links are broken. If HOLD is
          null, the socket is deallocated as well as having its connection
          broken. If HOLD is non null but N is allocated but not in use,
          deallocate it anyway.

*/

          declare
                    (return_code,
                     supplied_handle)   fixed binary(17) parameter;
          /* CLSE_PROC can be called from the clse command, from quit command, or from
             the break command. In the latter case, supplied_handle is the pin number
             of a broken link pin which must be closed. In the second case,
             supplied_handle = -2 denotes that all connections are to be closed.
             The first case is the standard one of decoding the supplied request.
          */

          declare
                    (handle_found,
                     delete_bit,
                     hold_found
                    )                   bit(1) aligned initial("0"b);

          declare
                    temp_string         char(10),
                    code                fixed bin(35),
                    state     fixed bin(6),
                    i                   fixed bin(8),
                    (err_code,
                    lower,
                    upper,
                    handle
                    )                   fixed bin(17);

          /* * * * * * END OF DECLARATIONS * * * * * */


          return_code = 0;

          if supplied_handle = -2 then go to continue;
          if supplied_handle ^= -1 then do;
                    lower,upper,handle = supplied_handle;
                    handle_found,hold_found = "1"b;
                    go to close_it;
                    end;

          if protocol = TENEX_PROTOCOL then do;
                    unspec(code) = get_TENEX_word();
                    handle = code;
                    if handle = 0 then go to get_hold_info;
                       else go to check_handle_validity;
                    end;


          call get_token (token);
          if token = "" then go to continue;
          temp_string = token;
          handle = cv_dec_check_(temp_string,err_code);
          if err_code ^= 0 then do;
                    hold_found = "1"b;
                    call get_token (token);
                    if token ^= "" then do;
                              err_code = 11;
                              rsexec_error = "BAD SYNTAX FOUND IN CLSE REQUEST";
                              go to clse_errors;
                              end;
                    go to continue;
                    end;
              else handle_found = "1"b;

check_handle_validity:
          if handle > hbound(server_socket_table,1) |
             handle < lbound(server_socket_table,1) then do;
                    err_code = 260;
                    rsexec_error = "NO SUCH HANDLE EXISTS";
                    go to clse_errors;
                    end;

          if server_socket_table(handle).listener_id_no ^= this_listener_id then do;
                    err_code = 20;
                    rsexec_error = "THIS SOCKET IS NOT YOURS";
                    go to clse_errors;
                    end;

          if protocol = TENEX_PROTOCOL then do;

get_hold_info:
                    unspec(code) = get_TENEX_word();
                    if code = -1 then hold_found = "1"b;
                    end;
             else if protocol = GENERAL_PROTOCOL then do;
                    call get_token (token);
                    if token ^= "" then hold_found = "1"b;
                    end;

continue:
          if ^ handle_found then do;
                    lower = lbound(server_socket_table,1);
                    upper = hbound(server_socket_table,1);
                    end;
             else lower,upper = handle;


close_it:
          do i = lower to upper;
                    if server_socket_table(i).listener_id_no = this_listener_id then
                       if (^handle_found & server_socket_table(i).socket_usage ^= LINKED ) | handle_found then do;

                              if server_socket_table(i).socket_usage = ALLOCATED then delete_bit = "1"b;
                              if server_socket_table(i).socket_usage ^= ALLOCATED then do;
/* we should pass this socket back to ourselves */
                                        call ncp_$close_connection(server_socket_table(i).ncp_index,
                                                  state,code);
                                        if code ^= 0 then do;
                                                  err_code = 273;
                                                  rsexec_error = "CANNOT CLOSE CONNECTION";
                                                  go to clse_errors;
                                                  end;
                                        end;

                              server_socket_table(i).socket_usage = ALLOCATED;
                              server_socket_table(i).type_for_transfer,
                              server_socket_table(i).link_subscript_or_mode = 0;
                              server_socket_table(i).link_segment_ptr = null();
                              server_socket_table(i).foreign_socket_id = "0"b;

                              if (^hold_found) | delete_bit then do;
                                        delete_bit = "0"b;
                                        call free_network_pin (i);
                                        end;
                              end;
                    end;

          if supplied_handle = -1 then call pos_ack();
          return;

clse_errors:
          return_code = err_code;
          if supplied_handle = -1 then call neg_ack(-err_code,rsexec_error);
          return;
end clse_proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
break_proc:
          procedure(action_flag,return_error);

/*
          Program by Gerard J. Rudisin

          RSEXEC procedure to process BREAK commands, the form of which is:

                    BREAK IDENTIFIER

          where IDENTIFIER is an optional user identifier (person.project) specifying
          a specific link to be broken. If it is not supplied, all links from the
          requesting user are to be broken.
                    "break_proc" can also be called from the QUIT command; in this case,
          action_flag = -1 and the intent is to break all links. Otherwise, go ahead
          and decode the arguments.

*/

          declare
                    (return_error,
                     action_flag)       fixed binary(17) parameter;

          declare
                    err_code            fixed bin(17),
                    socket_count        fixed bin(17),
                    temp                fixed bin(17),
                    user_specified      bit(1) aligned init("0"b);

          declare
                    user_id             char(23),
                    project_id          char(12),
                    dirname             char(168),
                    ARPAnet_msgs_name   char(34),
                    ARPAseg_ptr         pointer;

          /* * * * * * END OF DECLARATIONS * * * * * */


          return_error = 0;
          if action_flag ^= -1 then do;
               call get_token (token);
               if token ^= "" then do;
                    user_specified = "1"b;
                    temp = index(token,".");
                    if temp = 0 | temp = 1 | temp = length(token) then do;
                              err_code = 31;
                              rsexec_error = "ILLEGAL USER SPECIFICATION. SHOULD BE PERSON.PROJECT";
                              go to break_errors;
                              end;

                    socket_count = 0;
                    user_id = substr(token,1,temp - 1);
                    project_id = substr(token,temp + 1);
                    call ioa_$rsnnl(">udd>^a>^a",dirname,temp,project_id,user_id);

                    ARPAnet_msgs_name = before(user_id," ")||".ARPAnet_msgs";
                    call hcs_$initiate(dirname,ARPAnet_msgs_name,"",0b,1b,ARPAseg_ptr,(0));
                    if ARPAseg_ptr = null() then do;
                              err_code = 602;
                              rsexec_error = "USER HAS NO LINKS IN PROGRESS";
                              go to break_errors;
                              end;
                    end;
               end;

          do temp = lbound(server_socket_table,1) to hbound(server_socket_table,1);
                    if server_socket_table(temp).listener_id_no = this_listener_id then do;
                              if user_specified then
                                 if ARPAseg_ptr = server_socket_table(temp).link_segment_ptr &
                                    server_socket_table(temp).socket_usage = LINKED then go to got_one;
                                    else go to loop_end;

                                 else if server_socket_table(temp).socket_usage = LINKED
                                         then ARPAseg_ptr = server_socket_table(temp).link_segment_ptr;
                                         else go to loop_end;

got_one:

                              server_socket_table(temp).socket_usage = CONNECTED;

                              call clse_proc(temp,err_code);
                              if err_code ^= 0 then do;
                                        rsexec_error = "ERROR IN CLOSING SOCKET";
                                        go to break_errors;
                                        end;

                              if user_specified then socket_count = socket_count + 1;
                              end;

loop_end:
                    end;

          if user_specified then if socket_count ^= 2 then do;
                    err_code = 31;
                    rsexec_error = "INVALID PAIR OF SOCKETS FOR LINK";
                    go to break_errors;
                    end;

          if action_flag ^= -1 then call pos_ack();
          return;

break_errors:
          return_error = err_code;
          if action_flag ^= -1 then call neg_ack(-err_code,rsexec_error);
          return;

end break_proc;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
ptcl_proc:
          procedure();

/*

          Program by Gerard J. Rudisin

          RSEXEC subroutine to handle PTCL requests, of the form:

                    PTCL NEWMODE

          where NEWMODE is the desired mode, currently either GENERAL (or G), or
          TENEX (or T). The present working connections are closed and reopened in
          the bytesize appropriate to the new mode. All other sockets are untouched.

*/

          declare
                    TENEX_token         char(5),
                    new_mode            fixed bin(8),
                    err_code            fixed bin(17),
                    code                fixed bin(35),
                    new_size            fixed bin(35);

          /* * * * * * END OF DECLARATIONS * * * * * */




          if protocol = TENEX_PROTOCOL then do;
                    call get_TENEX_line(1);
                    call convert_pdp10_bytes_$direct_7_to_9(null(),
                              addr(input_chars_TENEX.byte(input_chars_TENEX.byte_offset)),0,2,(0),
                              addr(TENEX_token),0,length(TENEX_token) + 1, (0), (0));

                    input_chars_TENEX.byte_offset = input_chars_TENEX.byte_offset + 1;
                    if TENEX_token = "GENRL" then new_mode = GENERAL_PROTOCOL;
                       else if TENEX_token = "TENEX" then new_mode = TENEX_PROTOCOL;
                               else go to bad_protocol;

                    end;
          else do;
               call get_token (token);
               if token = "G" | token = "GENERAL"
               then new_mode = GENERAL_PROTOCOL;
               else if token = "T" | token = "TENEX"
                    then new_mode = TENEX_PROTOCOL;
                     else do;

bad_protocol:
                         call neg_ack (-11, "BAD SYNTAX:  ILLEGAL PROTOCOL MODE");
                         return;
                              end;
               end;

          if new_mode = protocol then do;
                    call pos_ack();
                    return;
                    end;

          if new_mode = GENERAL_PROTOCOL then new_size = 8;
             else if new_mode = TENEX_PROTOCOL then new_size = 36;

          if protocol = GENERAL_PROTOCOL then do;
                    call ioa_$rsnpnnl("+^/",output_string,output_chars_GENERAL.num_bytes);
                    call send_line();
                    end;
             else if protocol = TENEX_PROTOCOL then call pos_ack();

          if tracing then call ioa_("about to try reconnection");

          call iox_$control(P_iocb_ptr,"rsexec_reconnect",addr(new_size),code);

          if tracing then call ioa_("return from reconnection, code is ^d",code);
          if code ^= 0 then do;
                    err_code = 35;
                    rsexec_error = "WORKING CONNECTION COULD NOT BE REESTABLISHED IN NEW MODE";
                    server_error_code = code;
                    go to return_to_caller;
                    end;

          protocol = new_mode;
          if FISH_pointer ^= null() then protocol_type = new_mode;

          if new_mode = TENEX_PROTOCOL then do;
                    input_chars_TENEX.byte_offset = 0;
                    input_chars_TENEX.num_bytes = -1;
                    end;

          call pos_ack();
          return;

ptcl_errors:
          call neg_ack(-err_code,rsexec_error);
          return;

end ptcl_proc;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
susr_proc:
          procedure();

/*

          Program by Gerard J. Rudisin

          RSEXEC subroutine to carry out the SUSR (set user) command to log in a user for
          file transfer. The form of the command is:

                    SUSR USER_IDENTIFIER PASSWORD

          where USER_IDENTIFIER is of the form person.project, and PASSWORD is the
          users normal Multics password. This procedure logs the user in and turns
          his process over to the rsexec_file_server which communicates with the
          system server and is awakened to process file transfer commands.

*/


          declare
                    code                fixed bin(35),
                    test_flag           bit(1) init("0"b),
                    temp                fixed bin(17),
                    password            char(8),
                    err_code            fixed bin(17),
                    nelemt              fixed bin(24),
                    communicate_line    char(130) aligned,
                    dirname             char(168);

          /* * * * * * END OF DECLARATIONS * * * * * */


/*        Check to see if the user is already logged in from previous susr      */

          if susr_flag then do;
                    call ioa_$ioa_switch(susr_stream,"^a","@logout");
                    call iox_$close (susr_stream, (0));
                    call iox_$detach_iocb (susr_stream, susr_error_code);
                    FISH_pointer = null();
                    susr_flag = "0"b;
                    if susr_error_code ^= 0 then do;
                              err_code = 34;
                              rsexec_error = "ERROR IN LOGGING OUT PREVIOUS SUSR USER";
                              go to susr_errors;
                              end;
                    end;


/*        Decode arguments              */

          call get_token (token);
          temp = index(token,".");
          if temp = 0 | temp = 1 | temp = length(token) then do;
                    err_code = 31;
                    rsexec_error = "USERID MUST BE PERSON.PROJECT";
                    go to susr_errors;
                    end;

          susr_person_id = substr(token,1,temp - 1);
          susr_project_id = substr(token,temp + 1);
if test_flag then go to test_place;

/* The password is a separte ASCIZ string - i.e. a new TENEX line. */

          call get_token (token);
          password = token;
          if token = "" then do;
                    err_code = 30;
                    rsexec_error = "ILLEGAL PASSWORD";
                    go to susr_errors;
                    end;

/*        Create login sockets and try to login             */

          call iox_$find_iocb (unique_chars_ (""b), susr_stream, susr_error_code);
          call iox_$attach_iocb (susr_stream, "user_telnet_ mult,23 -connect icp", susr_error_code);
          if susr_error_code ^= 0 then do;

login_stream_error:
                    err_code = 34;
                    rsexec_error = "CANNOT LOGIN FOR SUSR";
                    go to susr_errors;
                    end;

          call iox_$open (susr_stream, 3, "0"b, susr_error_code);
          if susr_error_code ^= 0
          then goto susr_errors;
          communicate_line = "";
          do while(index(communicate_line,"Load") = 0);
                    call iox_$get_line(susr_stream,addr(communicate_line),length(communicate_line),
                              nelemt,susr_error_code);
                    if susr_error_code ^= 0 then do;

read_error:
                              if susr_flag then do; /* ie., if login occurred but rsexec_file_server
                                                            was not started up, logout the user */
                                        call ioa_$ioa_switch(susr_stream, "^a", "@logout");
                                        FISH_pointer = null();
                                        susr_flag = "0"b;
                                        end;

                              call iox_$close (susr_stream, (0));
                              call iox_$detach_iocb (susr_stream, susr_error_code);
                              go to login_stream_error;
                              end;
                    end;

          call ioa_$ioa_switch(susr_stream,"^a","login " || susr_person_id || " " ||
                    susr_project_id || " -ns -bf -print_off");

          communicate_line = "";
          call iox_$get_line(susr_stream,addr(communicate_line),length(communicate_line),
                    nelemt,susr_error_code);
          if susr_error_code ^= 0 then go to read_error;

          if index(communicate_line,"assword:") ^= 0 then do;
                    call ioa_$ioa_switch(susr_stream,"^a",password);
                    password = "";
                    end;
             else go to login_stream_error;

          communicate_line = "";
          do while (substr(communicate_line,1,2) ^= "r ");
                    call iox_$get_line(susr_stream,addr(communicate_line),length(communicate_line),
                              nelemt,susr_error_code);
                    if susr_error_code ^= 0 then go to read_error;

                    substr(communicate_line,nelemt) = "";
                    if communicate_line = "hangup" then go to read_error;
                    if index(communicate_line,"already logged in") ^= 0 then do;
                              err_code = 601;
                              rsexec_error = "ALREADY LOGGED IN";
                              call iox_$close (susr_stream, (0));
                              call iox_$detach_iocb (susr_stream, susr_error_code);
                              go to susr_errors;
                              end;

                    if index(communicate_line,"ogin incorrect") ^= 0 then go to read_error;
                    if index(communicate_line,"ncorrect login") ^= 0 then go to read_error;
                    end;

/*        If login successful (ready message received) send command and wait for response */

          susr_flag = "1"b;
          call ioa_$ioa_switch(susr_stream,"^a","@add_search_rules >user_dir_dir>CompNet>Library");
          call ioa_$ioa_switch(susr_stream,"^a","@rsexec_file_server");
test_place:
          communicate_line = "";
          do while (index(communicate_line,"** ") = 0);
if test_flag then do;
     communicate_line = "** SUCCESSFUL SETUP **";
     go to test_entrance;
     end;

                    call iox_$get_line(susr_stream,addr(communicate_line),length(communicate_line),
                              nelemt,susr_error_code);
                    if susr_error_code ^= 0 then go to read_error;
                    substr(communicate_line,nelemt) = "";

                    if index(communicate_line,"Error") ^= 0 then go to read_error;
                    if index(communicate_line,"** ") = 0 then go to loop_end;

test_entrance:
                    if index(communicate_line,"SUCCESSFUL SETUP ") ^= 0 then do;
                              call ioa_$rsnnl(">udd>^a>^a",dirname,temp,susr_project_id,susr_person_id);
                              temp = index(susr_person_id," ") - 1;
                              FISH_file_name = substr(susr_person_id,1,temp) || ".ARPA_file_info";
                              call hcs_$initiate(dirname,FISH_file_name,"",0b,1b,FISH_pointer,code);

                              if FISH_pointer = null() then do;
                                        go to read_error;
                                        end;

                              call ipc_$create_ev_chn(system_server_channel,code);
                              system_server_proc_id = get_process_id_();
                              protocol_type = protocol;
                              server_network_userid = binary (server_net_userid, 24);
                              susr_flag = "1"b;

                              end;
                       else go to read_error;

loop_end:
                    end;

          call pos_ack();
          return;


susr_errors:
          call neg_ack(-err_code,rsexec_error);
          return;

end susr_proc;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * */

mode_proc:
          procedure(action_flag);

/*
          Program by Gerard J. Rudisin

          RSEXEC procedure for the MODE and TYPE commands to decode arguments and check handle for validity.
          MODE and TYPE information is passed to a SUSR user process only when a transfer command is received.
          If action_flag then process MODE command, else process TYPE command. The form of both commands is:

                    <MODE or TYPE> <NEWMODE or NEWTYPE> HANDLE

*/


          declare
                    action_flag bit(1) parameter;

          declare
                    temp_string         char(10),
                    mode_string         char(5),
                    mode_type           fixed bin(17),
                    null_ind            fixed bin(17),
                    pin_number          fixed bin(8),
                    err_code            fixed bin(17),
                    code                fixed bin(35);

          /* * * * * * END OF DECLARATIONS * * * * * */




          if protocol = GENERAL_PROTOCOL
          then call get_token (token);

          else if protocol = TENEX_PROTOCOL
          then do;

                    call get_TENEX_line(1);
                    call convert_pdp10_bytes_$direct_7_to_9(null(),
                              addr(input_chars_TENEX.byte(input_chars_TENEX.byte_offset)),0,5,(0),
                              addr(mode_string),0,5,(0),(0));

          null_ind = index(mode_string,"");
          if null_ind > 0
          then mode_string = substr(mode_string,1,null_ind - 1);
          token = mode_string;

          end;

          if action_flag then do;
                    if token = "BLOCK" | token = "B" then mode_type = BLOCK;
                       else if token = "PAGE" | token = "P" then mode_type = PAGE;
                               else if token = "STREAM" | token = "S" then do;
                                        err_code = 522;
                                        rsexec_error = "MODE NOT IMPLEMENTED";
                                        go to mode_errors;
                                        end;
                                    else do;
                                        err_code = 501;
                                        rsexec_error = "UNRECOGNIZED MODE SPECIFICATION";
                                        go to mode_errors;
                                        end;
                    end;
             else do;
                    if token = "IMAGE" | token = "I" then mode_type = IMAGE;
                       else if token = "NASCII" | token = "NASCI" | token = "N" then do;
                              err_code = 522;
                              rsexec_error = "TYPE NOT IMPLEMENTED";
                              go to mode_errors;
                              end;
                            else do;
                              err_code = 500;
                              rsexec_error = "UNRECOGNIZED TYPE";
                              go to mode_errors;
                              end;
                    end;

          /* get handle */
          if protocol = GENERAL_PROTOCOL then do;
                    call get_token (token);
                    temp_string = token;
                    pin_number = cv_dec_check_(temp_string,err_code);
                    if err_code ^= 0 then do;
                              err_code = 11;
                              rsexec_error = "ILLEGAL CHARACTER IN HANDLE";
                              go to mode_errors;
                              end;
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    unspec(code) = get_TENEX_word();
                    pin_number = code;
                    end;

          /* check pin for validity */

          if pin_number < lbound(server_socket_table,1) |
             pin_number > hbound(server_socket_table,1) then do;
                    err_code = 260;
                    rsexec_error = "NO SUCH HANDLE EXISTS";
                    go to mode_errors;
                    end;

          if server_socket_table(pin_number).socket_usage = UNUSED |
             server_socket_table(pin_number).listener_id_no ^= this_listener_id then do;
                    err_code = 20;
                    rsexec_error = "YOU DO NOT OWN OR DID NOT ALLOCATE THIS SOCKET";
                    go to mode_errors;
                    end;

          if ^(server_socket_table(pin_number).socket_usage = ALLOCATED |
               server_socket_table(pin_number).socket_usage = CONNECTED ) then do;
                    err_code = 271;
                    rsexec_error = "SOCKET MUST NOT BE IN USE";
                    go to mode_errors;
                    end;

          if action_flag then server_socket_table(pin_number).link_subscript_or_mode = mode_type;
             else server_socket_table(pin_number).type_for_transfer = mode_type;

          call pos_ack();
          return;

mode_errors:
          call neg_ack(-err_code,rsexec_error);
          return;

end mode_proc;

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

transfer_proc:
          procedure(request_number,return_code);

/*
          Program by Gerard J. Rudisin

          RSEXEC procedure to prepare for the file transfer commands (RETRV,STORE,NAPN).
          This routine decodes the arguments, places the appropriate parameters in the
          FISH segment for the SUSR user,checks for pin validity, and passes off the socket,
          which the rsexec_file_server running in the SUSR users process will claim to
          do the actual transfer. The form of the commands is:

                    <COMMAND> FILENAME HANDLE

                    request_number = 1 for RETRV, 2 for STORE, and 3 for NAPN commands

*/

          declare
                    (request_number     fixed bin(17),
                     return_code        fixed bin(17))                parameter;

          declare
                    err_code            fixed bin(17),
                    code                fixed bin(35),
                    pin_number          fixed bin(8),
                    temp_string         char(10);

          /* * * * * * END OF DECLARATIONS * * * * * */


          return_code = 0;
          call get_token (token);
          parameter(1) = token;

          if protocol = GENERAL_PROTOCOL then do;
                    call get_token (token);
                    temp_string = token;
                    pin_number = cv_dec_check_(temp_string,err_code);
                    if err_code ^= 0 then do;
                              err_code = 11;
                              rsexec_error = "ILLEGAL CHARACTER IN HANDLE";
                              go to transfer_errors;
                              end;
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    unspec(code) = get_TENEX_word();
                    pin_number = code;
                    end;

          /* check for validity of pin */

          if pin_number < lbound(server_socket_table,1) |
             pin_number > hbound(server_socket_table,1) then do;
                    err_code = 260;
                    rsexec_error = "NO SUCH HANDLE EXISTS";
                    go to transfer_errors;
                    end;

          if server_socket_table(pin_number).socket_usage = UNUSED |
             server_socket_table(pin_number).listener_id_no ^= this_listener_id then do;
                    err_code = 20;
                    rsexec_error = "YOU DO NOT OWN OR DID NOT ALLOCATE THIS SOCKET";
                    go to transfer_errors;
                    end;

          if ^ (server_socket_table(pin_number).socket_usage = CONNECTED |
                server_socket_table(pin_number).socket_usage = FILE_TRANSFER ) then do;
                    err_code = 24;
                    rsexec_error = "SOCKET IS IN IMPROPER STATE FOR FILE TRANSFER";
                    go to transfer_errors;
                    end;

          if server_socket_table(pin_number).type_for_transfer = 0 |
             server_socket_table(pin_number).link_subscript_or_mode = 0 then do;
                    err_code = 522;
                    rsexec_error = "MODE OR TYPE NOT SET FOR THIS HANDLE";
                    go to transfer_errors;
                    end;

          if server_socket_table(pin_number).byte_size ^= 36 then do;
                    err_code = 520;
                    rsexec_error= "ONLY 36 BIT BYTES ARE LEGAL FOR TRANSFER";
                    go to transfer_errors;
                    end;

          if ((request_number = 2 | request_number = 3) & server_socket_table(pin_number).gender = WRITE) |
              (request_number = 1 & server_socket_table(pin_number).gender = READ) then do;
                    err_code = 222;
                    rsexec_error = "WRONG GENDER FOR THIS FILE TRANSFER OPERATION";
                    go to transfer_errors;
                    end;

          /* passoff the socket, and place the parameters for the user in the FISH segment */

          call ncp_$passoff_socket (server_socket_table (pin_number).ncp_index, file_server_proc_id, ""b, code);
          if code ^= 0 then do;
                    err_code = 275;
                    rsexec_error = "CANNOT PASSOFF SOCKET TO SUSR USER";
                    go to transfer_errors;
                    end;

          numeric_parameter(1) = pin_number;
          numeric_parameter(2) = server_socket_table(pin_number).gender;
          numeric_parameter(3) = server_socket_table(pin_number).byte_size;
          numeric_parameter(4) = server_socket_table(pin_number).link_subscript_or_mode;
          numeric_parameter(5) = server_socket_table(pin_number).type_for_transfer;

          server_socket_table(pin_number).socket_usage = FILE_TRANSFER;

          return;

transfer_errors:
          call neg_ack(-err_code,rsexec_error);
          return_code = err_code;
          return;

end transfer_proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
usinf_proc:
          procedure();

/*

          Program by Gerard J. Rudisin

          RSEXEC procedure to handle usinf requests, the format of which is:

                    USINF USERIDENTIFIER

          where USERIDENTIFIER refers to a single user of the form <person_id>.<project_id>
          or <person_id> or .<project_id>

*/


          declare
                    code                          fixed bin(35),
                    user_count                    fixed bin(17),
                    temp_string                   char(34);

          user_count = 0;

          call get_token (token);
          temp_string = token;
          if token = "" then do;
                    call neg_ack (-11, "NO USER WAS SPECIFIED IN THE USINF REQUEST.");
                    return;
                    end;

          call who_info_(temp_string,print_proc,code);

          if user_count = 0 then do;
                    if protocol = GENERAL_PROTOCOL then do;
                              call ioa_$rsnpnnl("+^/^a not logged in.^/",output_string,
                                        output_chars_GENERAL.num_bytes,temp_string);
                              call send_line();
                              end;
                       else if protocol = TENEX_PROTOCOL then call neg_ack(-602,"");
                    end;

          call pos_ack();

          return;

usinf_errors:
          call neg_ack(-code,rsexec_error);
          return;

/* * * * * * * * * * * * * * * * * * * * * */
print_proc:         procedure(login_name,entry_pointer);

          declare
                    (login_name char(*),
                     entry_pointer pointer
                    )         parameter;


          if user_count = 0 then if protocol = GENERAL_PROTOCOL then do;
                    call ioa_$rsnpnnl("+^/",output_string,output_chars_GENERAL.num_bytes);
                    call send_line();
                    end;
             else if protocol = TENEX_PROTOCOL then call pos_ack();

          user_count = user_count + 1;

          if protocol = TENEX_PROTOCOL
          then do;
               output_chars_TENEX.byte_offset = 0;
               output_chars_TENEX.num_bytes = 2;
               output_chars_TENEX.byte (0) = ""b;
               output_chars_TENEX.byte (1) = ""b;
               call send_line ();
                    return;
                    end;

          if entry_pointer -> whotab_entry.proc_type = 1 /* INTERACTIVE */
          then call ioa_$rsnpnnl("^a^/",output_string,output_chars_GENERAL.num_bytes,login_name);
             else call ioa_$rsnpnnl("^a logged in as absentee user (cannot be linked to).^/",
                    output_string,output_chars_GENERAL.num_bytes,login_name);

          call send_line();

          return;

end print_proc;
/* * * * * * * * * * * * * * * * * * * * * */

end usinf_proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/
ssinf_proc:
          procedure ();

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         ((cur_units, cur_users, max_units) fixed binary (17),
          (timeup, timedown) fixed binary (71),
          (timedown_string, timeup_string) character (24),
          system_id character (8),
          installation_id character (32),
          reason character (32))
               automatic;

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

          if protocol = GENERAL_PROTOCOL then do;
                    call ioa_$rsnpnnl ("+^/", output_string, output_chars_GENERAL.num_bytes);
                    call send_line();
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    output_chars_TENEX.byte(0) = (36)"1"b;
                    output_chars_TENEX.num_bytes = 1;
                    output_chars_TENEX.byte_offset = 0;
                    call send_line();
                    go to print_user_list;
                    end;

          call system_info_$sysid (system_id);
          call system_info_$installation_id (installation_id);

          call ioa_$rsnpnnl ("^5xMultics ^a; ^a^/", output_string, output_chars_GENERAL.num_bytes, system_id, installation_id);
          call send_line ();

          call system_info_$users((0),cur_users,max_units,cur_units);
          call ioa_$rsnpnnl ("^5xLoad = ^d out of ^d units; users = ^d^/", output_string, output_chars_GENERAL.num_bytes,
                    divide (cur_units, 10, 24, 0), divide (max_units, 10, 24, 0), cur_users);
          call send_line ();

          call system_info_$next_shutdown (timedown, reason, timeup);
          if timedown ^= 0
          then do;
               call date_time_ (timedown, timedown_string);
               call date_time_ (timeup, timeup_string);

               if reason < "" then reason = "";
               if timeup = 0
               then call ioa_$rsnpnnl ("^5xScheduled shutdown at ^a ^a^/", output_string, output_chars_GENERAL.num_bytes,
                              timedown_string, reason);
               else call ioa_$rsnpnnl ("^5xScheduled shutdown from ^a to ^a ^a^/", output_string, output_chars_GENERAL.num_bytes,
                              timedown_string, timeup_string, reason);

               call send_line ();
               end;

          call ioa_$rsnpnnl ("^/     CURRENT USERS^/", output_string, output_chars_GENERAL.num_bytes);

          call send_line ();

print_user_list:
          call who_info_ ("", print_who_line, server_error_code);
          if server_error_code ^= 0 then go to return_to_caller;

          call pos_ack ();

          return;

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

print_who_line:
          procedure (p_user_id, p_entry_ptr);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

          declare   (
                    p_user_id char(*),
                    p_entry_ptr         pointer
                    )                   parameter;

          declare
                    temp_string         char(32),
                    num_sig_chars       fixed bin(24),
                    num_TENEX_ascii     fixed bin(24);

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

          if protocol = GENERAL_PROTOCOL then do;
                    call ioa_$rsnpnnl ("^a^/", output_string, output_chars_GENERAL.num_bytes, p_user_id);
                    end;
             else if protocol = TENEX_PROTOCOL then do;
                    output_chars_TENEX.byte (0) = (36)"0"b;           /* contains job number and tty num      */
                    output_chars_TENEX.byte (1) = (36)"0"b;           /* contains ASCIZ string for prog name  */

                    temp_string = rtrim (p_user_id) || low (1);
                    num_sig_chars = length (rtrim (p_user_id)) + 1;

                    call convert_pdp10_bytes_$direct_9_to_7(null(),
                              addr(temp_string),0,num_sig_chars, (0),
                              addr(output_chars_TENEX.byte(2)),0,(dimension(output_chars_TENEX.byte,1) - 2) * 5, num_TENEX_ascii,
                              (0));

                    output_chars_TENEX.num_bytes = ceil(num_TENEX_ascii/5) + 2;
                    output_chars_TENEX.byte_offset = 0;

                    end;

          call send_line ();

          return;

end print_who_line;

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

end ssinf_proc;
/* * * * * * * * * * * * * * * * * * * * * * * * * */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

free_network_pin:
          procedure (p_pin_num);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_pin_num fixed binary (8)
               parameter;

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

          call ipc_$delete_ev_chn (server_socket_table (p_pin_num).event_channel, (0));

          server_socket_table (p_pin_num).event_channel = 0;
          server_socket_table (p_pin_num).gender = 0;
          server_socket_table (p_pin_num).listener_id_no = 0;

          server_socket_table (p_pin_num).socket_usage = UNUSED;
          call ncp_$detach_socket (server_socket_table (p_pin_num).ncp_index, (0));
          server_socket_table (p_pin_num).ncp_index = ""b;

          server_socket_table (p_pin_num).unused_brother = -1;

          call net_pin_manager_$free_pins (2, p_pin_num - mod (p_pin_num, 2), (0));

          return;

end;      /* end free_network_pin                          */

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

error_handler:
          procedure (p_err_code);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_err_code fixed binary(35) parameter;

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

          revert error;

          call cu_$gen_call (com_err_, cu_$arg_list_ptr ());

          server_error_code = p_err_code;

          goto return_to_caller;

end error_handler;

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

end rsexec_server_;




		    rsexec_who.pl1                  01/09/80  1048.4rew 01/09/80  0923.0       49059



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

rsexec_who:
          procedure (P_host);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          P_host character (*)
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (num_read fixed binary (24),
          position fixed binary (24),
          err_code fixed binary (35),
          more_data_to_come bit (1),
          ios_status bit (72) aligned,
          required_response character (1),
          plus character (1),
          temp_string character (256),
          net_iocb pointer)
               automatic;

     declare
          1 workspace aligned,
             2 byte (0 : 2) bit (9) unaligned;

          /* * * * * TEXT SECTION REFERENCES * * * * * * * */

     declare
         (PLUS      initial ("+"),
          ATSIGN    initial ("@"),
          NL        initial ("
"))
               character (1) internal static;

     declare
         (NET character (32) initial ("network_stream"),
          PROG character (32) initial ("rsexec_who"))
               internal static;

          /* * * * * ENTRY & PROCEDURE DECLARATIONS  * * * */

     declare
          com_err_ constant entry options (variable),
          ioa_ constant entry options (variable),
          ioa_$ioa_stream constant entry options (variable),
          ios_$attach constant entry (char (*), char (*), char (*), char (*), bit (72) aligned),
          ios_$detach constant entry (char (*), char (*), char (*), bit (72) aligned),
          ios_$write constant entry (char (*), ptr, fixed bin (24), fixed bin (24), fixed bin (24), bit (72) aligned),
          ios_$write_ptr constant entry (ptr, fixed bin (24), fixed bin (24)),
          iox_$find_iocb constant entry (char (*), ptr, fixed bin (35)),
          iox_$get_line constant entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35));

     declare
          (addr, length, substr)
               builtin;

          /* * * * * STACK REFERENCES  * * * * * * * * * * */

     declare
          cleanup condition;

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

          call cleanup_all ();                              /* make sure nothing from previous invocations    */

          on cleanup
               call cleanup_all ();

          call iox_$find_iocb ((NET), net_iocb, err_code);
          if err_code ^= 0
          then do;
               call com_err_ (err_code, (PROG), "Trying to find IOCB.");
               return;
               end;

          call ios_$attach ((NET), "net_ascii_", P_host || ",245", "icp,read,write", ios_status);
          if substr (ios_status, 1, 36) ^= ""b
          then do;
               call com_err_ (substr (ios_status, 1, 36), (PROG), "Unable to connect to foreign host.");
               return;
               end;

                              /* Otherwise, we have a full duplex connection to foreign host */

          call ioa_$ioa_stream ((NET), "SSINF");
          call ioa_$ioa_stream ((NET), "QUIT");

          workspace.byte (0) = "000001010"b;
          workspace.byte (1) = unspec (ATSIGN);
          workspace.byte (2) = unspec (PLUS);

          call iox_$get_line (net_iocb, addr (temp_string), length (temp_string), num_read, err_code);
          if err_code ^= 0
          then do;
               call com_err_ (err_code, (PROG), "Unable to read from host.");
               call cleanup_all ();
               return;
               end;

          if (substr (temp_string, 1, 1) ^= "+") /*  & "0"b */
          then do;
               call com_err_ ((36)"0"b, (PROG), "Improper response from host:  ^a", substr (temp_string, 1, num_read));
               call cleanup_all ();
               return;
               end;

          more_data_to_come = "1"b;
          do while (more_data_to_come);
               call iox_$get_line (net_iocb, addr (temp_string), length (temp_string), num_read, err_code);
               if err_code ^= 0
               then do;
/*                  call com_err_ (err_code, (PROG), "Connection erroneously closed by foreign host.");  */
                    call cleanup_all ();
                    return;
                    end;

               position = index (substr (temp_string, 1, num_read), "+
");
               if position ^= 0
               then do;
                    more_data_to_come = "0"b;
                    substr (temp_string, position, 1) = NL;
                    num_read = position;
                    end;

               call ios_$write_ptr (addr (temp_string), 0, num_read);
               end;

          call ioa_ ("");

          call cleanup_all ();

          return;

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

cleanup_all:
          procedure ();

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

          call ios_$detach ((NET), "", "", ios_status);
          return;

end;

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

end;




		    run_rsexec_server.pl1           01/09/80  1048.4rew 01/09/80  0923.0      115128



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

run_rsexec_server:
          procedure ();

/*             "run_rsexec_server" -- program to listen for requests for RSEXEC */
/*        servers on the local host.  Normally, it will create a task to handle */
/*        that request.  That task will then run the program rsexec_server_,    */
/*        which will listen for and act upon RSEXEC commands that come in.      */
/*             There is also a debugging mode which functions in a non-tasking  */
/*        environment.  It is fudged into this program so that it can (1) take  */
/*        advantage of useful internal subroutines, and (2) so that it doesn't  */
/*        get out of date because of non-maintenance.                           */

/*        Originally created by D. M. Wells for original rsexec_server_.        */
/*        Modified by Gerald J. Rudisin to handle differences for more complete */
/*             rsexec_server_ that handles file requests.                       */
/*        Modified by D. M. Wells, July 3, 1977, to fix some tracing bugs and   */
/*             to take advantage of some new tasking features.  It was also     */
/*             renamed from rsexec_overseer.                                    */

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
         (contact_pin fixed binary (8),
          contact_userid fixed binary (24),
          contact_socket fixed binary (32),
          err_code fixed binary (35),
          (want_tasking, want_tracing) bit (1))
               automatic;

          /* * * * * INTERNAL STATIC DECLARATIONS  * * * * */

     declare
          eight fixed binary (35) initial (8)
               internal static;

          /* * * * * TEXT SECTION REFERENCES * * * * * * * */

     declare
          PROG character (32) initial ("run_rsexec_server")
               internal static options (constant);

          /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */

          /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */

     declare
         (error_table_$badopt,
          error_table_$noarg)
               fixed binary (35) external static;

          /* * * * * ENTRY & PROCEDURE DECLARATIONS  * * * */

     declare
          com_err_ constant entry options (variable),
          cu_$arg_list_ptr constant entry () returns (ptr),
          cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr),
          cu_$gen_call constant entry (entry, ptr),
          cv_dec_check_ constant entry (char (*), fixed bin (35)) returns (fixed bin (35)),
          ioa_ entry options (variable),
          ioa_$rsnnl entry options (variable),
          iox_$attach_iocb entry (ptr, char (*), fixed bin (35)),
          iox_$close entry (ptr, fixed bin (35)),
          iox_$control entry (ptr, char (*), ptr, fixed bin (35)),
          iox_$detach_iocb entry (ptr, fixed bin (35)),
          iox_$open entry (ptr,fixed bin (17), bit (1) aligned, fixed bin (35)),
          rsexec_server_ constant entry (ptr, fixed bin (16), fixed bin (32), bit (*), fixed bin (35)),
          rsexec_server_$initialize_the_goodies entry,
          run_net_service_ constant entry (fixed bin (24), fixed bin (8), fixed bin (17), fixed bin (17), entry, entry, entry, bit (*), fixed bin (35));

     declare
          (addr, divide, mod, null)
               builtin;

          /* * * * * STACK REFERENCES  * * * * * * * * * * */

     declare
          cleanup condition,
          error condition;

          /* * * * * INCLUDE FILES * * * * * * * * * * * * */


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

          call process_options (cu_$arg_list_ptr ());

          on cleanup
               call cleanup_after_command ();

          if want_tracing
          then call ioa_ ("T:  Listening for RSEXEC requests on userid ^d, pin ^d.",
                         contact_userid, contact_pin);

          call rsexec_server_$initialize_the_goodies ();

          call run_net_service_ (contact_userid, contact_pin, 20, 15, attach_streams, invoke_request_processor, detach_streams, want_tasking || want_tracing, err_code);
          if err_code ^= 0
          then call abort_command (err_code, PROG, "From run_net_service_");

return_from_command:
          return;

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

invoke_request_processor:
          procedure (p_iocb_ptr, p_foreign_host, p_foreign_socket, p_err_code);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
         (p_foreign_host fixed binary (16),
          p_foreign_socket fixed binary (32),
          p_err_code fixed binary (35),
          p_iocb_ptr pointer)
               parameter;

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

          call iox_$control (p_iocb_ptr, "complete_open", null (), p_err_code);
          if p_err_code ^= 0
          then return;

          call rsexec_server_ (p_iocb_ptr, p_foreign_host, p_foreign_socket, (want_tracing), p_err_code);

          return;

end;      /* invoke_request_processor                      */

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

attach_streams:
          procedure (p_iocb_ptr, p_foreign_host, p_foreign_socket, p_local_socket, p_err_code);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
         (p_foreign_host fixed binary (16),
          p_foreign_socket fixed binary (32),
          p_local_socket fixed binary (32),
          p_err_code fixed binary (35),
          p_iocb_ptr pointer)
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

    declare
          device_spec character (96)
               automatic;

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

          p_err_code = 0;

          if want_tracing
          then call ioa_ ("T:  attaching streams : data for ^d,^d at ^p",
                    p_foreign_host, p_foreign_socket, p_iocb_ptr);

          call ioa_$rsnnl ("net_data_transfer_ ^d,^d -local_pin ^d -connect initiate", device_spec, (0),
                    p_foreign_host, p_foreign_socket + 2, mod (p_local_socket, 256));

          call iox_$attach_iocb (p_iocb_ptr, device_spec, p_err_code);
          if p_err_code ^= 0
          then return;

          call iox_$control (p_iocb_ptr, "setsize", addr (eight), (0));
          call iox_$control (p_iocb_ptr, "asynchronous_open", null (), (0));

          call iox_$open (p_iocb_ptr, 3, "0"b, p_err_code);
          if p_err_code ^= 0
          then return;

          return;

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

detach_streams:
          entry (p_iocb_ptr, p_err_code);

          p_err_code = 0;

          call iox_$close (p_iocb_ptr, (0));

          return;

end;      /* end attach_streams                            */

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

process_options:
          procedure (p_arg_list_ptr);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_arg_list_ptr pointer
               parameter;

          /* * * * * AUTOMATIC STORAGE DECLARATIONS  * * * */

     declare
          (arg_indx fixed binary (17),
          arg_length fixed binary (24),
          arg_ptr pointer)
               automatic;

          /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */

     declare
          based_argument character (arg_length)
               based;

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

          want_tasking = "1"b;
          want_tracing = "0"b;
          contact_userid = -1;
          contact_pin = -1;
          contact_socket = -1;

          do arg_indx = 1 repeat (arg_indx + 1) while (got_argument (arg_indx));
               call process_control_argument (arg_ptr -> based_argument);
               end;

          if contact_socket ^= -1
          then do;
               contact_userid = divide (contact_socket, 256, 24, 0);
               contact_pin = mod (contact_socket, 256);
               end;
          else if (contact_userid = -1) & (contact_pin = -1)
               then do;
                    contact_userid = 0;
                    contact_pin = 245;
                    end;

          return;

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

got_argument:
          procedure (P_arg) returns (bit (1));

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          P_arg fixed binary (17)                           /* index of the argument which we are to address  */
               parameter;

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

          call cu_$arg_ptr_rel (P_arg, arg_ptr, arg_length, err_code, p_arg_list_ptr);
          if err_code = 0
          then return ("1"b);

          if err_code = error_table_$noarg
          then return ("0"b);

          call abort_command (err_code, PROG, "Attempting to get argument #^d.", P_arg);

end;      /* end got_argument                              */

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

process_control_argument:
          procedure (p_control_arg);

          /* * * * * PARAMETER DECLARATIONS  * * * * * * * */

     declare
          p_control_arg character (*)
               parameter;

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

          if p_control_arg = "-no_tasking"
          then do;
               want_tasking = "0"b;
               return;
               end;

          if p_control_arg = "-debug"
          then do;
               want_tracing = "1"b;
               return;
               end;

          if p_control_arg = "-pin"
          then do;
               arg_indx = arg_indx + 1;
               if ^ got_argument (arg_indx)
               then call abort_command (err_code, PROG, "The -pin control argument requires a pin specification.");

               contact_pin = cv_dec_check_ (arg_ptr -> based_argument, err_code);
               if err_code ^= 0
               then call abort_command (err_code, PROG, "Not a valid decimal pin number:  ^a", arg_ptr -> based_argument);

               return;
               end;

          if p_control_arg = "-userid"
          then do;
               arg_indx = arg_indx + 1;
               if ^ got_argument (arg_indx)
               then call abort_command (err_code, PROG, "The -userid control argument requires a userid specification.");

               contact_userid = cv_dec_check_ (arg_ptr -> based_argument, err_code);
               if err_code ^= 0
               then call abort_command (0, PROG, "Not a decimal socket number:  ^a", arg_ptr -> based_argument);

               return;
               end;

          if p_control_arg = "-socket"
          then do;
               arg_indx = arg_indx + 1;
               if ^ got_argument (arg_indx)
               then call abort_command (err_code, PROG, "The -socket control argument requires a socket specification.");

               contact_socket = cv_dec_check_ (arg_ptr -> based_argument, err_code);
               if err_code ^= 0
               then call abort_command (err_code, PROG, "Not a valid decimal socket number:  ^a", arg_ptr -> based_argument);

               return;
               end;

          call abort_command (error_table_$badopt, PROG, p_control_arg);

end;      /* end process_control_argument                  */

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

end;      /* end process_options                           */

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

cleanup_after_command:
          procedure ();

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

          return;

end;      /* end cleanup_after_command                     */

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

abort_command:
          procedure options (variable);

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

          revert error;

          call cu_$gen_call (com_err_, cu_$arg_list_ptr ());

          call cleanup_after_command ();

          goto return_from_command;

end;      /* end abort_command                             */

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

end;      /* end run_rsexec_server                         */



		    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
