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;