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: 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: 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 . or or . */ 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