canonicalizer_.pl1 09/23/77 1036.9rew 09/22/77 1715.0 116307 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1973 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ canonicalizer_: proc (inptr, ilength, outptr, maxlength, outlength, flags, code); /* Last modified by dm wells to fix (per p green fix) a bug whereby */ /* "\102\103" was translated into "B\103" rather than "BC" */ dcl instring char (ilength) based (inp), cv_oct_check_ external entry (char (*), fixed bin) returns (fixed bin), error_table_$area_too_small fixed bin external, outstring char (lastin_high_column) based (outp), inptr ptr, outptr ptr, longsw bit (1), ilength fixed bin, code fixed bin, maxlength fixed bin, outlength fixed bin, chars (0: 1) based char (1), bit9 bit (9) unaligned based, (i, j, position_start, position_end, last_position_start, extra_space_count) fixed bin, (index, max, mod) builtin, lastin_high_column fixed bin, ini fixed bin, lastin_cur_column fixed bin, column fixed bin, high_column fixed bin, tabsize fixed bin static init (10), outp ptr, inp ptr, ch char (1), ch1 char (1), substr builtin, addr builtin; dcl 1 flags aligned, 2 (do_can, do_erkl, do_esc, do_tty33) bit (1) unaligned; dcl (cent initial ("\"), minus initial ("-"), apostrophe initial ("'"), grave initial ("`"), lparen initial ("("), rparen initial (")"), lbrace initial ("{"), rbrace initial ("}"), exc_pt initial ("!"), vert_bar initial ("|"), equals initial ("="), tilde initial ("~"), kill initial ("@"), erase initial ("#"), newline init (" "), backspace init (""), carriage_return init (" "), tab init (" ")) char (1) static; dcl space char (10) static initial (" "); dcl binary builtin; longsw = do_esc | do_tty33 | do_erkl; column, lastin_high_column, lastin_cur_column, outlength, code = 0; outp = outptr; inp = inptr; do ini = 1 to ilength; ch = substr (instring, ini, 1); if dbsw then call ioa_ ("^a", substr (instring, 1, ini)); if ch = newline then do; /* terminate current line */ trailing: if lastin_high_column ^= 0 then if substr (outstring, lastin_high_column, 1) = space then do; lastin_high_column = lastin_high_column - 1; go to trailing; end; lastin_high_column = lastin_high_column + 1; substr (outstring, lastin_high_column, 1) = newline; /* add newline to end */ /* ADDITION */ if longsw then do; position_start, position_end = 1; do while (position_end < lastin_high_column + 1); last_position_start = max (position_start, 1); position_start = position_end; if do_can then do position_end = position_end + 1 by 2 while (position_end <= lastin_high_column); if substr (outstring, position_end, 1) ^= backspace then go to out; end; out: if position_end = position_start then position_end = position_end + 1; if substr (outstring, position_start, 1) = cent then do; if ^do_esc then go to check_erkl; j = 0; do i = position_start+1 to position_start+3 while (substr (outstring, i, 1)<"8"&substr (outstring, i, 1) >= "0"); j = j * 8 + cv_oct_check_ (substr (outstring, i, 1), 0); end; i = i - 1; if i = position_start then do; ch1 = substr (outstring, i + 1, 1); if ch1 = erase then go to shift; if ch1 = kill then go to shift; if ch1 = cent then do; shift: substr (outstring, position_start) = substr (outstring, position_end); lastin_high_column = lastin_high_column - 1; end; else if do_tty33 then do; if (ch1 >= "A" & ch1 <= "Z") then; else if ch1 = minus then ch1 = backspace; else if ch1 = apostrophe then ch1 = grave; else if ch1 = lparen then ch1 = lbrace; else if ch1 = rparen then ch1 = rbrace; else if ch1 = exc_pt then ch1 = vert_bar; else if ch1 = equals then ch1 = tilde; else go to real_cent; substr (outstring, position_end, 1) = ch1; go to shift; real_cent: end; end; else do; addr (outp -> chars (position_start-1)) -> bit9 = bit (binary (j, 9)); substr (outstring, position_start + 1) = substr (outstring, i+1); lastin_high_column = lastin_high_column - i + position_start; position_end, position_start = position_start + 1; end; end; else check_erkl: if do_erkl then if index (substr (outstring, position_start, position_end - position_start), erase) ^= 0 then do; if position_end - position_start = 1 then do; if substr (outstring, last_position_start, 1) = space then do last_position_start = last_position_start to 1 by -1 while (substr (outstring, last_position_start - 1, 1) = space | substr (outstring, last_position_start - 1, 1) = tab); end; substr (outstring, last_position_start) = substr (outstring, position_end); lastin_high_column = lastin_high_column - position_end + last_position_start; position_start = last_position_start - 1; position_end = last_position_start; end; else do; substr (outstring, position_start) = substr (outstring, position_end); lastin_high_column = lastin_high_column - position_end + position_start; position_end = position_start; position_start = position_start - 1; end; end; else if index (substr (outstring, position_start, position_end - position_start), kill) ^= 0 then do; substr (outstring, 1) = substr (outstring, position_end); lastin_high_column = lastin_high_column - position_end + 1; position_start = 0; position_end = 1; end; end; if substr (outstring, lastin_high_column - 1, 1) = cent then do; lastin_cur_column, lastin_high_column = lastin_high_column - 2; column = 0; go to end_char_loop; end; end; /* END ADDITION */ outlength = outlength + lastin_high_column; /* add line to file */ outp = addr (outp -> chars (lastin_high_column)); /* make outp point to end of output */ lastin_high_column, column, lastin_cur_column = 0; /* we are at beginning */ end; else if ch = carriage_return then lastin_cur_column, column = 0; /* back to beginning of line */ else if ch = backspace then if do_can then do; /* back up a character position */ column = max (column-1, 0); if lastin_cur_column = lastin_high_column then if substr (outstring, lastin_cur_column, 1) = space then do; lastin_cur_column, lastin_high_column = lastin_cur_column - 1; /* forget space on end of line */ go to end_char_loop; end; if substr (outstring, lastin_cur_column, 1) = tab then do; extra_space_count = 0; do j = lastin_cur_column - 1 to 1 by -1; ch = substr (outstring, j, 1); if ch = newline then go to found_tenmod; if ch = tab then go to found_tenmod; if ch = carriage_return then go to found_tenmod; if ch = backspace then extra_space_count = extra_space_count - 1; else extra_space_count = mod (extra_space_count+ 1, 10); end; found_tenmod: extra_space_count = 9 - extra_space_count; lastin_high_column = lastin_high_column + extra_space_count; if lastin_high_column ^= lastin_cur_column then substr (outstring, lastin_cur_column) = substr (space, 1, extra_space_count + 1) || substr (outstring, lastin_cur_column + 1, lastin_high_column - lastin_cur_column - extra_space_count); lastin_cur_column = lastin_cur_column + extra_space_count - 1; go to end_char_loop; end; lastin_cur_column = lastin_cur_column - 1; /* look back */ back_up: if lastin_cur_column < 0 then lastin_cur_column = 0; else if substr (outstring, lastin_cur_column, 1) = backspace then do; /* must back to beginning of char position */ lastin_cur_column = lastin_cur_column - 2; go to back_up; end; end; else go to end_char_loop; else if ch = tab then do; /* reluctantly let them through, remaining ever vigilant */ i = column; column = column + tabsize - mod (column, tabsize); /* next tab stop */ if lastin_cur_column = lastin_high_column then do; substr (outstring, lastin_cur_column+1, 1) = tab; /* add enough to column count */ if lastin_high_column + 1 > maxlength then go to crump; lastin_high_column, lastin_cur_column = lastin_high_column + 1; go to end_char_loop; end; else if column > high_column then do; i = column - high_column; if lastin_high_column + i > maxlength then go to crump; substr (outstring, lastin_high_column + 1, i) = space; lastin_high_column, lastin_cur_column = lastin_high_column + i; end; else if do_can then do; do lastin_cur_column = lastin_cur_column + 1 to lastin_high_column while (i <= column); if substr (outstring, lastin_cur_column, 1) = carriage_return then i = 0; else if substr (outstring, lastin_cur_column, 1) = backspace then i = i - 1; else i = i + 1; end; lastin_cur_column = lastin_cur_column - 1; end; go to end_char_loop; end; else do; /* normal character */ column = column + 1; if lastin_cur_column = lastin_high_column then do; /* at end of line? */ if lastin_cur_column + 1 > maxlength then go to crump; lastin_cur_column, lastin_high_column = lastin_cur_column + 1; /* one more character */ substr (outstring, lastin_cur_column, 1) = ch; end; else do; if ch = space then do; dospace: lastin_cur_column = lastin_cur_column + 1; go to scan_loop; end; insert_after_char: ch1 = substr (outstring, lastin_cur_column+1, 1); /* look at next char */ if ch = ch1 then go to dospace; if ch1 = space then do; substr (outstring, lastin_cur_column+1, 1) = ch; /* replace space */ lastin_cur_column = lastin_cur_column + 1; go to end_char_loop; end; if ch < ch1 then do; do i = lastin_high_column to lastin_cur_column + 1 by -1; substr (outstring, i+2, 1) = substr (outstring, i, 1); end; if lastin_high_column + 2 > maxlength then go to crump; substr (outstring, lastin_cur_column+1, 2) = ch||backspace; lastin_high_column = lastin_high_column + 2; lastin_cur_column = lastin_cur_column + 3; scan_loop: if lastin_cur_column ^= lastin_high_column then if substr (outstring, lastin_cur_column+1, 1) = backspace then do; lastin_cur_column = lastin_cur_column + 2; go to scan_loop; end; end; else if ch1 < ch then do; lastin_cur_column = lastin_cur_column + 1; if lastin_cur_column = lastin_high_column then do; if lastin_high_column + 2 > maxlength then go to crump; substr (outstring, lastin_cur_column+1, 2) = backspace||ch; lastin_cur_column, lastin_high_column = lastin_cur_column + 2; go to end_char_loop; end; if do_can then if substr (outstring, lastin_cur_column+1, 1) = backspace then do; lastin_cur_column = lastin_cur_column + 1; go to insert_after_char; end; do i = lastin_high_column to lastin_cur_column by -1; substr (outstring, i+2, 1) = substr (outstring, i, 1); end; substr (outstring, lastin_cur_column, 2) = ch||backspace; lastin_high_column = lastin_high_column + 2; lastin_cur_column = lastin_cur_column + 2; end; end; end; end_char_loop: if dbsw then do; call ioa_ ("^a", substr (outstring, 1, lastin_high_column)); call ioa_ ("^a^/", substr (outstring, 1, lastin_cur_column) || "*_"); end; if lastin_cur_column = lastin_high_column then high_column = column; end; outlength = outlength + lastin_high_column; return; crump: substr (outstring, 1, maxlength) = "NON-CANONICALIZED GARBAGE"; /* look; why not? Helps debugging! */ code = error_table_$area_too_small; return; debug: entry; dcl ioa_ ext entry options (variable), dbsw bit (1) aligned static initial (""b); dbsw = "1"b; return; nodebug: entry; dbsw = ""b; return; end;  interpret_absi_status_.pl1 09/23/77 1036.9rew 09/22/77 1715.0 53901 interpret_absi_status_: procedure (P_absi_status, P_modes, P_printable_message, P_error_code); /* "interpret_absi_status_" -- procedure to produce a printable */ /* representation of the IOM status of the ABSI (Asynchronous Bit-Serial */ /* Interface), used to interface the ARPA Network IMP to Multics. */ /* Originally created by D. M. Wells, Sept., 1976. */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (P_error_code fixed binary (35), P_modes bit (*), /* bits to say different ways to print things */ P_absi_status bit (*), P_printable_message character (*) varying) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (brief bit (1), absi_status_vary bit (72) varying, status_message character (256) varying) automatic; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare major_status_name (0 : 15) character (36) varying internal static options (constant) initial ( "Ready", "Major Status 0001", "Major Status 0010", "Data Alert", "Major Status 0100", "Command Reject", "Major Status 0110", "Major Status 0111", "Busy", /* Channel/Peripheral Subsystem Busy */ "Major Status 1001", "Major Status 1010", "Major Status 1011", "Major Status 1100", "Major Status 1101", "Major Status 1110", "Major Status 1111"); declare substatus_name (1 : 6) character (20) varying internal static options (constant) initial ( "Incomplete Message", /* Substatus 1xx xxx */ "Host Down", /* Substatus x1x xxx */ "IMP Down", /* Substatus xx1 xxx */ "Parity Error", /* Substatus xxx 1xx */ "Substatus 000010", /* Substatus xxx x1x */ "Invalid Opcode"); /* Substatus xxx xx1 */ /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */ /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare error_table_$action_not_performed fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare ioa_$rsnnl constant entry options (variable); declare (bit, length, substr) builtin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ P_error_code = 0; P_printable_message = ""; absi_status_vary = P_absi_status; brief = P_modes; /* we will copy out the brief bit, even though we */ /* don't do anything with it yet. */ status_message = ""; if length (absi_status_vary) < 12 then do; P_error_code = error_table_$action_not_performed; return; end; if substr (absi_status_vary, 1, 1) ^= "1"b then do; call ioa_$rsnnl ("Invalid status: ^24.3b.", P_printable_message, (0), bit (absi_status_vary, 72)); return; end; if substr (absi_status_vary, 2, 1) ^= "0"b then do; P_printable_message = "Device Absent."; return; end; status_message = status_message || interpret_channel_status (substr (absi_status_vary, 3, 4), substr (absi_status_vary, 7, 6)); P_printable_message = status_message; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ interpret_channel_status: procedure (p_major_bits, p_substatus_bits) returns (char (256) varying); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_major_bits bit (4), p_substatus_bits bit (6)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (sb_indx fixed binary (17), mj_name character (36) varying, sb_string character (132) varying) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if p_major_bits = ""b then mj_name = ""; else mj_name = major_status_name (binary (p_major_bits, 4)); sb_string = ""; do sb_indx = lbound (substatus_name, 1) by 1 to hbound (substatus_name, 1); if substr (p_substatus_bits, sb_indx, 1) then do; if length (sb_string) ^= 0 then sb_string = sb_string || ", "; sb_string = sb_string || substatus_name (sb_indx); end; end; if sb_string = "" then if mj_name = "" then return ("Ready."); else return (mj_name || "."); else if mj_name = "" then return (sb_string || "."); else return (mj_name || ": " || sb_string || "."); end; /* end interpret_channel_status */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end interpret_absi_status_ */ end;  logger_.pl1 10/03/77 1118.7rew 10/03/77 0930.1 363879 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ logger_: procedure (); /* This is the Logger for Multics. This module handles requests */ /* for service from other Network hosts. Currently, this module */ /* handles requests for normal Login, and File Transfer Protocol (FTP) */ /* services. After this module has received a request, it interacts */ /* with the net_tty_ package to get a pseudo-TTY channel for the user at */ /* the other end to talk to. */ /* Initial coding by T. P. Skinner, April 1971. */ /* Completely rewritten by D. M. Wells in Oct, 1975, to fix security */ /* holes brought out by a change in the rest of the Answering */ /* Service. Also, at that time, the names logger_ and net_tty_ */ /* went away, and the net_as_ dispatch module was invented. */ /* Modified by D. M. Wells, Oct. 1976, to use features provided by the */ /* version 4 NCP. In particular, logger_ no longer calls in to */ /* force-deactivate sockets (they are now "cleared"), and the */ /* subroutine which used to check for re-used socket indices has */ /* been eliminated (the NCP now uses [almost] unique indicies). */ /* Modified by D. M. Wells, Feb. 1977, to keep a better history and to */ /* allow more socket states during a reset_log_socket call. */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (P_error_code fixed binary (35), P_ev_msg_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (dispatch_state fixed binary (2), state fixed binary (6), frgn_host fixed binary (16), array_indx fixed binary (17), new_service_state fixed binary (3), net_socket_group fixed binary (24), num_trans fixed binary (24), frgn_socket fixed binary (32), err_code fixed binary (35), access_ename character (32), access_dir character (168), cs_ptr pointer) automatic; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ declare (ncp_state fixed binary (17) initial (0), logp pointer initial (null ())) internal static; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare (MILLION fixed binary (20) initial (1000000), PROG character (32) varying initial ("logger_")) internal static options (constant); declare ALLOW_RFC_QUEUING fixed binary (12) initial (10) internal static options (constant); /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare 1 ev_message aligned based, 2 common like event_message_template.common, 2 dataptr pointer; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare (as_data_$version character (8) aligned, net_as_$version fixed binary (17), net_as_$logger_grace_period fixed binary (17), net_as_$ptty_grace_period fixed binary (17), net_as_$timeout_factor fixed binary (17), net_as_$logger_socket_group fixed binary (24), net_as_$testing bit (1), net_as_$tracing bit (36) aligned, net_as_$log_table_name character (32), net_as_$trace_iocb pointer) external static; declare 1 net_as_$icp_services aligned external static, 2 num_services fixed binary (17), /* number of services in effect */ 2 service (10), 3 service_type fixed binary (17), /* AS Services type -- LOGIN, FTP, etc. */ 3 log_pin fixed binary (8), /* ICP socket number (socket-group = 0) */ 3 service_name character (8) unaligned, /* Name of service -- TELNET, FTP, etc. */ 3 ptty_info bit (36), /* random bits which describe attributes */ 3 padd bit (36); declare (error_table_$imp_down, error_table_$namedup, error_table_$net_invalid_state, error_table_$net_not_up, error_table_$segnamedup) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare condition_ constant entry (char (*), entry), convert_binary_integer_$decimal_string constant entry (fixed bin (35)) returns (char (12) varying), get_lock_id_ constant entry () returns (bit (36) aligned), get_process_id_ constant entry () returns (bit (36) aligned), get_wdir_ constant entry () returns (char (168)), hcs_$chname_file constant entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$make_seg constant entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$truncate_seg constant entry (ptr, fixed bin (19), fixed bin (35)), hcs_$wakeup constant entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)), ioa_$ioa_switch 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), ptr, fixed bin (17), fixed bin (35)), ipc_$reset_ev_call_chn constant entry (fixed bin (71), fixed bin (35)), ncp_$accept_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$add_global_ev_chn constant entry (fixed bin (71), fixed bin (35)), ncp_$clear_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$close_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$detach_socket constant entry (bit (36), fixed bin (35)), ncp_$get_foreign_socket constant entry (bit (36), fixed bin (16), fixed bin (32), fixed bin (6), fixed bin (35)), ncp_$get_socket_state constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$listen_for_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$reject_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$set_bytesize constant entry (bit (36), fixed bin (8), fixed bin (35)), ncp_$write_data constant entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), net_$ncp_network_status constant entry (fixed bin (17), ptr, fixed bin (35)), net_$ncp_order constant entry (bit (36), fixed bin (12), ptr, fixed bin (6), fixed bin (35)), net_log_ constant entry options (variable), net_log_$net_error_log constant entry options (variable), net_ring1_user_$get_access_dir constant entry (char (*), fixed bin (35)), net_tty_io_$net_tty_io_init constant entry (ptr, fixed bin (35)), net_tty_xtach_$close_pseudo_tty constant entry (fixed bin (17), fixed bin (35)), net_tty_xtach_$hunt_free_pseudo_tty constant entry (fixed bin (17), fixed bin (16), fixed bin (32), fixed bin (24), fixed bin (35)), net_tty_xtach_$net_report_down constant entry (fixed bin (35)), net_tty_xtach_$net_tty_xtach_init constant entry (ptr, fixed bin (35)), ncp_$attach_priv_socket constant entry (fixed bin (24), fixed bin (8), fixed bin (71), bit (36), fixed bin (35)), timer_manager_$alarm_wakeup constant entry (fixed bin (71), bit (2), fixed bin (71)), timer_manager_$reset_alarm_wakeup constant entry (fixed bin (71)); declare (addr, baseno, bit, clock, dimension, hbound, lbound, mod, null, substr) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include log_tbl; % include net_as_states; % include net_event_template; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ return_to_caller: /* place to get out of logger_ routine */ return; /* * * * * * * * * * * * * * * * * * * * * * * * */ ncp_state_wakeup: entry (P_ev_msg_ptr); if logp -> ltbl.logger_service_state = LOGGER_services_off then return; /* this logger facility is turned off */ call net_$ncp_network_status (ncp_state, null (), err_code); if err_code ^= 0 then return; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: NCP state change, new state is ^d", PROG, ncp_state); if ncp_state = 2 then new_service_state = LOGGER_services_up; else new_service_state = LOGGER_network_down; if new_service_state = logp -> ltbl.logger_service_state then return; /* no change in network state */ if new_service_state = LOGGER_services_up then call activate_services ("NCP now up"); else do; call net_tty_xtach_$net_report_down ((0)); logp -> ltbl.logger_service_state = new_service_state; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ logger_wakeup: entry (P_ev_msg_ptr); cs_ptr = P_ev_msg_ptr -> ev_message.dataptr; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: wakeup for ^p (log state = ^d, net state ^d)", PROG, cs_ptr, cs_ptr -> cs.logger_state, logp -> ltbl.logger_service_state); if ^ net_as_$testing then call condition_ ("any_other", sig_handler); if baseno (cs_ptr) ^= baseno (logp) then do; call net_log_ (0, "^a: Bad pointer on wakeup ^p", PROG, cs_ptr); return; end; if (cs_ptr -> cs.service_index < 1) | (cs_ptr -> cs.service_index > logp -> ltbl.num_services) | (cs_ptr -> cs.log_pin ^= logp -> ltbl.contact_socket (cs_ptr -> cs.service_index).log_pin) then do; call net_log_ (0, "^a: Bad pointer on wakeup ^p", PROG, cs_ptr); return; end; cs_ptr -> cs.num_logger_wakeups = cs_ptr -> cs.num_logger_wakeups + 1; recheck_environment: if logp -> ltbl.logger_service_state ^= LOGGER_services_up /* NCP or IMP was down */ then return; dispatch_state = cs_ptr -> cs.logger_state; if (dispatch_state < lbound (log_dispatch, 1)) | (dispatch_state > hbound (log_dispatch, 1)) then do; call net_log_ (0, "^a: Bad state of log socket (^d)", PROG, dispatch_state); return; end; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: dispatching from state ^a (^d)", PROG, SERVICE_states (dispatch_state), dispatch_state); goto log_dispatch (dispatch_state); /* * * * * * * * * * * * * * * * * * * */ log_dispatch (0): /* SERVICE_unavailable */ return; /* * * * * * * * * * * * * * * * * * * */ log_dispatch (1): /* SERVICE_listening */ call ncp_$get_foreign_socket (cs_ptr -> cs.log_sock_handle, frgn_host, frgn_socket, state, err_code); if err_code ^= 0 then do; call log_socket_error (err_code, state, "checklog"); goto force_clear_log_socket; end; if state = 2 then return; /* All quiet, wait some more */ if state = 4 then do; call close_log_socket ("acknowledge RFC abort"); if reset_log_socket (err_code) then; goto recheck_environment; end; if state ^= 3 then do; call close_log_socket ("improper state"); return; end; cs_ptr -> cs.num_logger_contacts = cs_ptr -> cs.num_logger_contacts + 1; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: processing request from host ^d, socket ^d", PROG, frgn_host, frgn_socket); call set_service_state (SERVICE_allocation_wait, "1"b, state, "ICP-open"); call net_tty_xtach_$hunt_free_pseudo_tty (cs_ptr -> cs.service_index, frgn_host, frgn_socket, net_socket_group, err_code); if err_code ^= 0 then do; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: rejecting connection due to ^w", PROG, err_code); /* should fill history array */ cs_ptr -> cs.num_logger_rejects = cs_ptr -> cs.num_logger_rejects + 1; call ncp_$reject_connection (cs_ptr -> cs.log_sock_handle, state, (0)); call close_log_socket ("rejecting connection"); return; end; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: accepting connection with socket-group ^d", PROG, net_socket_group); call ncp_$accept_connection (cs_ptr -> cs.log_sock_handle, state, err_code); if (state ^= 6) | (err_code ^= 0) then do; call log_socket_error (err_code, state, "acceptlg"); call close_log_socket ("unable to accept connection"); return; end; cs_ptr -> cs.socket32 = ""b; substr (cs_ptr -> cs.socket32, 1, 24) = bit (net_socket_group, 24); /* manufacture socket number */ goto log_dispatch (SERVICE_allocation_wait); /* * * * * * * * * * * * * * * * * * * */ log_dispatch (2): /* SERVICE_allocation_wait */ call ncp_$write_data (cs_ptr -> cs.log_sock_handle, addr (cs_ptr -> cs.socket32), 1, num_trans, state, err_code); if (err_code ^= 0) | (state ^= 6) then do; call close_log_socket ("connection destroyed"); call net_tty_xtach_$close_pseudo_tty (cs_ptr -> cs.tty_idx, (0)); /* close the p-tty sockets */ return; end; if num_trans = 1 then do; /* we sent this data, be happy and go away */ call close_log_socket ("normal acceptance"); return; end; /* otherwise, see if we have timed-out yet */ if clock () < cs_ptr -> cs.logger_state_timeout then return; /* we haven't timed out yet, go wait some more */ cs_ptr -> cs.num_timeouts = cs_ptr -> cs.num_timeouts + 1; call close_log_socket ("timeout on allocation"); call net_tty_xtach_$close_pseudo_tty (cs_ptr -> cs.tty_idx, (0)); return; /* * * * * * * * * * * * * * * * * * * */ log_dispatch (3): /* SERVICE_close_wait */ call ncp_$get_socket_state (cs_ptr -> cs.log_sock_handle, state, err_code); if err_code ^= 0 then do; call log_socket_error (err_code, state, "checklog"); goto force_clear_log_socket; end; if (state = 1) | (state = 2) then if reset_log_socket (err_code) then goto recheck_environment; if clock () < cs_ptr -> cs.logger_state_timeout then return; goto force_clear_log_socket; /* * * * * * * * * * * * * * * * * * */ force_clear_log_socket: if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: force-deactivating log socket ^p", PROG, cs_ptr); cs_ptr -> cs.num_force_clears = cs_ptr -> cs.num_force_clears + 1; call ncp_$close_connection (cs_ptr -> cs.log_sock_handle, (0), (0)); call ncp_$clear_connection (cs_ptr -> cs.log_sock_handle, (0), (0)); if activate_log_socket (err_code) then goto recheck_environment; call net_log_$net_error_log (2, err_code, PROG, "Network ^a service (listening on socket ^d) disabled due to activation error.", cs_ptr -> cs.log_type, cs_ptr -> cs.log_pin); call set_service_state (SERVICE_unavailable, "0"b, 0, "broken"); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_service_state: procedure (p_new_logger_state, p_set_timeout, p_sock_state, p_comment); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_new_logger_state fixed binary (3), p_sock_state fixed binary (6), p_set_timeout bit (1), p_comment character (8)) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: log socket ^p set to state ^d.", PROG, cs_ptr, p_new_logger_state); cs_ptr -> cs.logger_state = p_new_logger_state; call timer_manager_$reset_alarm_wakeup (cs_ptr -> cs.logger_event_chn); cs_ptr -> cs.logger_state_timeout = 0; if p_set_timeout then do; cs_ptr -> cs.logger_state_timeout = clock () + logp -> ltbl.logger_grace_period; call timer_manager_$alarm_wakeup (cs_ptr -> cs.logger_state_timeout, "00"b, cs_ptr -> cs.logger_event_chn); end; call fill_history_slot (0, p_sock_state, p_comment); return; end; /* end set_service_state */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ fill_history_slot: procedure (p_code, p_sock_state, p_comment); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_sock_state fixed binary (6), p_code fixed binary (35), p_comment character (8)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare slot fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ slot = mod (cs_ptr -> cs.history.num_state_changes, dimension (cs_ptr -> cs.history.state_block, 1)); cs_ptr -> cs.history.state_block (slot).entry_time = clock (); cs_ptr -> cs.history.state_block (slot).status_code = p_code; cs_ptr -> cs.history.state_block (slot).netstate = ncp_state; cs_ptr -> cs.history.state_block (slot).socket_state = p_sock_state; cs_ptr -> cs.history.state_block (slot).function = 0; cs_ptr -> cs.history.state_block (slot).log_state = cs_ptr -> cs.logger_state; cs_ptr -> cs.history.state_block (slot).comment = p_comment; cs_ptr -> cs.history.num_state_changes = cs_ptr -> cs.history.num_state_changes + 1; return; end; /* end fill_history_slot */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close_log_socket: procedure (p_reason); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_reason character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: closing log socket ^p because ^a", PROG, cs_ptr, p_reason); call ncp_$close_connection (cs_ptr -> cs.log_sock_handle, state, err_code); if (err_code ^= 0) & (err_code ^= error_table_$net_invalid_state) then goto force_clear_log_socket; call set_service_state (SERVICE_close_wait, "1"b, state, "closwait"); if (state = 1) | (state = 2) | (state = 3) then do; if ^ reset_log_socket (err_code) then goto force_clear_log_socket; goto recheck_environment; end; return; end; /* end close_log_socket */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ activate_log_socket: procedure (p_err_code) returns (bit (1)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_err_code fixed binary (35) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: activating log socket ^p (pin ^d).", PROG, cs_ptr, cs_ptr -> cs.log_pin); cs_ptr -> cs.num_activations = cs_ptr -> cs.num_activations + 1; call ncp_$attach_priv_socket (net_as_$logger_socket_group, cs_ptr -> cs.log_pin, cs_ptr -> cs.logger_event_chn, cs_ptr -> cs.log_sock_handle, p_err_code); if p_err_code ^= 0 then do; call log_socket_error (p_err_code, 0, "activlog"); return ("0"b); end; call ncp_$set_bytesize (cs_ptr -> cs.log_sock_handle, 32, (0)); call set_service_state (SERVICE_close_wait, "0"b, 0, "actv-log"); return (reset_log_socket (p_err_code)); end; /* end activate_log_socket */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reset_log_socket: procedure (p_err_code) returns (bit (1)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_err_code fixed binary (35) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call net_$ncp_order (cs_ptr -> cs.log_sock_handle, ALLOW_RFC_QUEUING, null, (0), (0)); call ncp_$listen_for_connection (cs_ptr -> cs.log_sock_handle, state, p_err_code); if (state ^= 2) & (state ^= 3) & (state ^= 4) then do; call log_socket_error (p_err_code, state, "resetlog"); return ("0"b); end; call set_service_state (SERVICE_listening, "0"b, state, "lstn-log"); p_err_code = 0; return ("1"b); end; /* end reset_log_socket */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ log_socket_error: procedure (p_report_code, p_sock_state, p_explanation); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_sock_state fixed binary (6), p_report_code fixed binary (35), p_explanation character (8)) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (p_report_code = error_table_$imp_down) | (p_report_code = error_table_$net_not_up) then do; if logp -> ltbl.logger_service_state ^= LOGGER_services_up then goto return_to_caller; logp -> ltbl.logger_service_state = LOGGER_network_down; call net_$ncp_network_status (ncp_state, null (), (0)); if ncp_state = 0 then call net_log_ (1, "^a: The Network Control Program is not operating.", PROG); else call net_log_ (2, "^a: The Network Control Program is not operating.", PROG); call net_tty_xtach_$net_report_down ((0)); goto return_to_caller; end; call fill_history_slot (p_report_code, p_sock_state, p_explanation); call net_log_$net_error_log (0, p_report_code, PROG, "^a logger socket error ""^a"" (ncp state = ^d).", cs_ptr -> cs.log_type, p_explanation, p_sock_state); return; end; /* end log_socket_error */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ activate_services: procedure (p_reason); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_reason character (*) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare service_indx fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ logp -> ltbl.logger_service_state = LOGGER_services_up; /* assume net is up, will check later */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Activating Network ICP services for ^a.", PROG, p_reason); call net_log_ (0, "^a: Activating Network ICP Services for ^a.", PROG, p_reason); do service_indx = 1 by 1 to net_as_$icp_services.num_services; cs_ptr = addr (logp -> ltbl.contact_socket (service_indx)); if ^ activate_log_socket ((0)) then call set_service_state (SERVICE_close_wait, "1"b, 0, "actv-srv"); end; return; end; /* end activate_services */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ logger_init: entry (P_error_code); P_error_code = 0; call hcs_$make_seg (get_wdir_ (), net_as_$log_table_name, "", 1011b, logp, err_code); if logp = null then do; call net_log_$net_error_log (2, err_code, PROG, "Network startup error -- unable to create log_tbl"); return; end; call hcs_$truncate_seg (logp, 0, (0)); logp -> ltbl.time_initialized = clock (); logp -> ltbl.version_number = cur_ltbl_version_5; logp -> ltbl.max_length = 100; logp -> ltbl.max_inuse = 0; logp -> ltbl.logger_grace_period = net_as_$logger_grace_period * MILLION * net_as_$timeout_factor; /* normally 20 secs, but 200 secs for testing */ logp -> ltbl.ptty_grace_period = net_as_$ptty_grace_period * MILLION * net_as_$timeout_factor; /* normally 60 secs, but 600 secs for testing */ logp -> ltbl.as_processid = get_process_id_ (); logp -> ltbl.as_lockid = get_lock_id_ (); /* At this point, we should initialize all entries in */ /* log_tbl; however, by design, the truncation of the seg */ /* left all entries in an initialized state. */ if net_as_$icp_services.num_services > hbound (logp -> ltbl.contact_socket, 1) then do; return; end; logp -> ltbl.num_services = net_as_$icp_services.num_services; if net_as_$icp_services.num_services = 0 then do; return; end; do array_indx = 1 to net_as_$icp_services.num_services; cs_ptr = addr (logp -> ltbl.contact_socket (array_indx)); call ipc_$create_ev_chn (cs_ptr -> cs.logger_event_chn, err_code); if err_code = 0 then call ipc_$decl_ev_call_chn (cs_ptr -> cs.logger_event_chn, logger_wakeup, cs_ptr, 1, err_code); if err_code ^= 0 then do; call net_log_$net_error_log (2, err_code, PROG, "Creating logger event channel."); return; end; cs_ptr -> cs.service_index = array_indx; cs_ptr -> cs.service_type = net_as_$icp_services.service (array_indx).service_type; cs_ptr -> cs.log_pin = net_as_$icp_services.service (array_indx).log_pin; cs_ptr -> cs.log_type = net_as_$icp_services.service (array_indx).service_name; cs_ptr -> cs.ptty_info = net_as_$icp_services.service (array_indx).ptty_info; end; call net_ring1_user_$get_access_dir (access_dir, (0)); do array_indx = 1 by 1 to net_as_$icp_services.num_services; cs_ptr = addr (logp -> ltbl.contact_socket (array_indx)); access_ename = "socket." || convert_binary_integer_$decimal_string ((cs_ptr -> cs.log_pin)) || ".acs"; /* Notice that we are explicitly assuming socket */ /* group 0. This helps prevent testing sessions */ /* from accidentally taking over the AS sockets. */ call hcs_$chname_file (access_dir, "AS_logger", "", access_ename, err_code); if (err_code ^= 0) & (err_code ^= error_table_$segnamedup) & (err_code ^= error_table_$namedup) then call net_log_$net_error_log (1, err_code, "Setting access for pin ^d, service ^a.", cs_ptr -> cs.log_pin, cs_ptr -> cs.log_type); end; call ipc_$create_ev_chn (logp -> ltbl.ncp_global_channel, err_code); if err_code = 0 then call ipc_$decl_ev_call_chn (logp -> ltbl.ncp_global_channel, ncp_state_wakeup, null (), 1, err_code); if err_code ^= 0 then call net_log_$net_error_log (2, err_code, PROG, "Creating NCP global channel."); call ncp_$add_global_ev_chn (logp -> ltbl.ncp_global_channel, err_code); /* tells who to inform when network goes down */ logp -> ltbl.logger_service_state = LOGGER_network_down; /* to tell logger that it isn't working yet but has been inited */ call net_tty_xtach_$net_tty_xtach_init (logp, (0)); call net_tty_io_$net_tty_io_init (logp, (0)); call net_log_ (0, "^a: Initializing Multics Network services -- AS ^a, Net AS ^d.", PROG, as_data_$version, net_as_$version); call activate_services ("NET-AS initialization"); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ /* This entry halts the processing of ICPs. It does */ /* not change the state or functioning of any pseudo-tty */ /* already connected. */ logger_stop: entry (); logp -> ltbl.logger_service_state = LOGGER_services_off; /* this halts the processing of any new services */ do array_indx = 1 by 1 to net_as_$icp_services.num_services; /* now make the NCP reject */ /* the attempts */ cs_ptr = addr (logp -> ltbl.contact_socket (array_indx)); call ncp_$detach_socket (cs_ptr -> cs.log_sock_handle, (0)); cs_ptr -> cs.log_sock_handle = ""b; end; return; /* * * * * * * * * * * * * * * * * * * * * * * */ /* This entry restarts the processing of ICPs (on all */ /* channels listed in service table. */ logger_restart: entry (); logp -> ltbl.logger_service_state = LOGGER_services_up; /* Presume it's up */ call ipc_$reset_ev_call_chn (logp -> ltbl.ncp_global_channel, (0)); call hcs_$wakeup (get_process_id_ (), logp -> ltbl.ncp_global_channel, 0, (0)); call activate_services ("restart services"); return; /* * * * * * * * * * * * * * * * * * * * * * * */ /* This entry sets some variables so that this module */ /* as well as all the Network Answering Service code, */ /* performs in a test environment, which does not bother */ /* the normal Multics Answering Service. */ logger_test: entry (); net_as_$testing = "1"b; net_as_$logger_socket_group = 63; net_as_$timeout_factor = 10; /* wait 10 times as long for timeouts if testing */ return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ sig_handler: procedure (p_mc_ptr, p_condition, p_crawlout_mc_ptr, p_info_ptr, p_continue); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_continue bit (1) aligned, p_condition character (*), (p_crawlout_mc_ptr, p_info_ptr, p_mc_ptr) pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare table_indx fixed binary (17) automatic; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare ok_conditions (1 : 5) character (32) initial ( "cput", "alrm", "quit", "mme2", "program_interrupt") internal static options (constant); /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: unclaimed signal of ^a", PROG, p_condition); p_continue = "1"b; do table_indx = lbound (ok_conditions, 1) by 1 to hbound (ok_conditions, 1); if p_condition = ok_conditions (table_indx) then return; /* return to signal_ and let continue up stack */ end; call net_log_$net_error_log (0, 0, PROG, "Network error ""^a"" signalled.", p_condition); /* call as_$dump here ?? */ goto return_to_caller; end; /* end sig_handler */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* BEGIN MESSAGE DOCUMENTATION Message: logger_: Bad pointer on wakeup LOC S: net-as (severity0) T: $run M: The ARPANET portion of the Answering Service has detected an improper pointer to LOC. This may be the result of a store error, a programming error, or a bad patch. The system attempts to recover and resume normal operation. A: $note Message: logger_: Bad state of log socket (STATE) S: net-as (severity0) T: $run M: The ARPANET portion of the Answering Service has detected an improper state for a socket which was listening for service requests. This may be the result of a store error, a programming error, or a bad patch. A: $note The system attempts to recover and continue normal operation. Message: logger_: ERROR-MESSAGE Network SERVICE service (listening on socket SOCKET-NUM) disabled due to activation error. S: net-as (severity2) T: $run M: Due to a fatal error, the system has ceased to listen to socket SOCKET and will stop providing the service SERVICE to ARPANET users. A: $inform_sa Message: logger_: The Network Control Program is not operating. S: net-as (severity2) T: $run M: The Network Control Program is not functioning and no users can login from the ARPANET. A: $inform_sa Usually, the ARPANET Network Daemon is logged in during system start-up. The Daemon may have encountered an error and logged itself out. Message: logger_: ERROR-MESSAGE SERVICE logger socket error "EXPLANATION" (ncp state = SOCKET-STATE). S: net-as (severity0) T: $run M: An error has occurred while processing the socket listening for requests for the SERVICE service. A: $ignore The system has reinitialized the service and resumed normal operation. Message: logger_: Activating Network ICP Services for REASON. S: net-as (severity0) T: $run M: The Answering Service ARPANET sockets are being reinitialized. This is usually due to the system being initialized or the ARPANET coming up. A: $ignore Message: logger_: ERROR-MESSAGE Network startup error -- unable to create log_tbl S: net-as (severity2) T: $init M: The ARPANET portion of the Answering Service was unable to create its data segment. This error may be due to an improper library installation. ARPANET users will be unable to login until the problem is corrected and the system has been re-booted. A: $contact_sa After the problem has been fixed, the system should be shutdown and re-booted so that ARPANET users can login. Message: logger_: ERROR-MESSAGE Creating logger event channel. S: net-as (severity2) T: $init M: The ARPANET portion of the Answering Service was unable to create interprocess-communication channels. This error may be due to an improper library installation. ARPANET users will be unable to login until the problem is corrected and the system has been re-booted. A: $contact_sa After the problem has been fixed, the system should be shutdown and re-booted so that ARPANET users can login. Message: logger_: ERROR-MESSAGE Setting access for pin SOCKET, service SERVICE. S: net-as (severity1) T: $init M: The ARPANET portion of the Answering Service was unable to set proper access to control the socket SOCKET, which is normally used for service SERVICE. This may be due to a problem associated with the directory >system_control_1>ncp. A: $contact_sa After the problem is corrected, the system may need to be shutdown and re-booted so that ARPANET users can login. Message: logger_: ERROR-MESSAGE Creating NCP global channel. S: net-as (severity2) T: $init M: The ARPANET portion of the Answering Service was unable to setup an interprocess-communication channel to be informed when the ARPANET goes up and down. A: $contact_sa If the ARPANET goes down and comes back up, the operator may need to manually reinitial the ARPANET portion of the Answering Service. Message: logger_: Initializing Multics Network services -- AS AS-VERSION, Net AS NET-VERSION. S: net-as (severity0) T: $init M: The ARPANET portion of the Answering Service has been initialized. The version number of the Answering Service is AS-VERSION; the version number of the ARPANET portion is NET-VERSION. A: $ignore Message: logger_: ERROR-MESSAGE Network error "CONDITION" signalled. S: net-as (severity0) T: $run M: While the ARPANET portion of the Answering Service was running, the condition CONDITION was signalled. A: $note The system attempts to recover and resume normal operation. END MESSAGE DOCUMENTATION */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end logger_ */  meld_log.pl1 09/23/77 1036.9rew 09/22/77 1715.0 80757 %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ meld_log: mlg: proc; /* coded by Edwin W. Meyer, Jr. on 100372 */ dcl alen fixed bin; /* length of char string argument */ dcl apr ptr; /* pointer to char string argument */ dcl dn char (168); /* directory name */ dcl en char (32); /* entry name */ dcl extra_log_sw bit (1); /* to keep track of log levels */ dcl i fixed bin; /* temporary */ dcl icode fixed bin (35); /* error code */ dcl limit_time fixed bin (71); /* no entry of later time to be melded */ dcl limit_time_sw bit (1); /* = 1 if limit_time to be observed */ dcl nargs fixed bin; /* number of args meld_log called with */ dcl net_log_ptr ptr; /* pointer to the melded log */ dcl on char (32); /* old name for renaming melded log */ dcl reason char (20); /* reason for error message */ dcl timestr char (16); /* character string time */ dcl tpr ptr; /* temporary */ dcl update_sw bit (1); /* = 1 if last entry processed of source logs to be updated */ dcl winner_log fixed bin; /* log selected for next entry into melded log */ dcl xlls char (12); /* suffix for renamed melded log */ dcl arg char (alen) based (apr); /* template to pick up argument to meld_log */ dcl log_entry bit (1152) aligned based; dcl 1 log_data (2) aligned, /* contains data on the two logs to be melded */ 2 logp ptr, /* pointer to current log */ 2 nextp ptr, /* pointer to next log to be processed (or null) */ 2 latestp ptr, /* pointer to latest log processed */ 2 curidx fixed bin, /* index of next entry to be melded */ 2 maxidx fixed bin; /* last entry in this log */ % include netlog; dcl clock_ entry () returns (fixed bin (71)); dcl com_err_ entry options (variable); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl (addr, null, substr) builtin; setup: limit_time_sw, update_sw = ""b; xlls = ""; examine_args: call cu_$arg_count (nargs); if (nargs < 3) | (nargs > 5) then goto err_arg_count; /* incorrect number of arguments */ process_options: do i = 4 to nargs; /* args 4 and 5 must be options */ call cu_$arg_ptr (i, apr, alen, icode); if icode ^= 0 then goto err; if apr -> arg = "-ud" then update_sw = "1"b; else if apr -> arg = "-update" then update_sw = "1"b; else do; /* only other possibility is a time argument */ limit_time_sw = "1"b; call convert_date_to_binary_ (apr -> arg, limit_time, icode); if icode ^= 0 then goto err_date; end; end; init_source_logs: do i = 1 to 2; /* initiate both logs */ call GET_PATH (i); /* get pathname for this log into dn and en */ extra_log_sw = ""b; log_data (i).nextp = null; /* to start with */ call_init: call hcs_$initiate (dn, en, "", 0, 1, tpr, icode); if tpr = null then if ^extra_log_sw then goto err_no_log; /* first log not found */ else do; call com_err_ (icode, "meld_log", "old log ^a not found", en); call SWITCH_LOG (i); tpr = log_data (i).logp; end; else log_data (i).logp, log_data (i).latestp = tpr; if tpr -> net_log_file.lep = 0 then if tpr -> net_log_file.lls ^= "" then if tpr -> net_log_file.lls > "" then do; if extra_log_sw then goto err_log_depth; extra_log_sw = "1"b; log_data (i).nextp = tpr; en = "log.-." || tpr -> net_log_file.lls; goto call_init; end; get_log_data: log_data (i).curidx = tpr -> net_log_file.lep + 1; log_data (i).maxidx = tpr -> net_log_file.count; if log_data (i).curidx > log_data (i).maxidx then if extra_log_sw then call SWITCH_LOG (i); else goto err_prev_processed; end; init_melded_log: call GET_PATH (3); /* get the dn and en of the melded log */ call FIND_MELD_LOG; /* to create of initiate it */ cycle_start_point: /* the cycle of finding and melding an entry starts here */ get_winner: if log_data (1).logp = null then winner_log = 2; else if log_data (2).logp = null then winner_log = 1; else if log_data (1).logp -> net_log_file.array (log_data (1).curidx).time > log_data (2).logp -> net_log_file.array (log_data (2).curidx).time then winner_log = 2; else winner_log = 1; check_time_limit: if limit_time_sw then if log_data (winner_log).logp -> net_log_file.array (log_data (winner_log).curidx).time >= limit_time then goto finish; /* we've had it */ check_melded_log_full: if net_log_ptr -> net_log_file.count = net_log_ptr -> net_log_file.max then do; /* it's full, alright */ call INSERT_LAST_DATE; call date_time_ (clock_ (), timestr); /* get the current time */ xlls = substr (timestr, 11, 4) || "-" || substr (timestr, 1, 5); on = "log.-." || xlls; call hcs_$chname_seg (net_log_ptr, en, on, icode); if icode ^= 0 then goto err_chname_meld; call hcs_$terminate_noname (net_log_ptr, icode); call FIND_MELD_LOG; /* get a new one */ end; insert_winner_entry: i, net_log_ptr -> net_log_file.count = net_log_ptr -> net_log_file.count + 1; addr (net_log_ptr -> net_log_file.array (i).time) -> log_entry = addr (log_data (winner_log).logp -> net_log_file.array (log_data (winner_log).curidx).time) -> log_entry; check_winner_plus_one: log_data (winner_log).curidx = log_data (winner_log).curidx + 1; if log_data (winner_log).curidx > log_data (winner_log).maxidx then do; /* wefind the next one */ if update_sw then log_data (winner_log).latestp -> net_log_file.lep = log_data (winner_log).curidx - 1; call SWITCH_LOG (winner_log); if (log_data (1).logp = null) & (log_data (2).logp = null) then goto finish; end; goto cycle_start_point; finish: if net_log_ptr -> net_log_file.count = 0 then goto empty_log; if update_sw then do i = 1 to 2; /* update the counts for both logs */ if log_data (i).latestp ^= null then log_data (i).latestp -> net_log_file.lep = log_data (i).curidx - 1; end; call INSERT_LAST_DATE; return; /* normal end point */ empty_log: reason = "melded log is empty"; icode = 0; call COM_ERR; return; err_arg_count: reason = "arg_count"; call COM_ERR; return; err_chname_meld: reason = "chname_meld"; call COM_ERR; return; err_date: reason = "date"; call COM_ERR; return; err_log_depth: reason = "log_depth"; call COM_ERR; return; err_meld_update: reason = "meld_update"; call COM_ERR; return; err_no_log: reason = "no_log"; call COM_ERR; return; err_no_meld_log: reason = "no_meld_log"; call COM_ERR; return; err_prev_processed: reason = "prev_processed"; call COM_ERR; return; err: reason = ""; call COM_ERR; return; GET_PATH: proc (arg_idx); dcl arg_idx fixed bin; call cu_$arg_ptr (arg_idx, apr, alen, icode); if icode ^= 0 then goto err; call expand_path_ (apr, alen, addr (dn), addr (en), icode); if icode ^= 0 then goto err; end GET_PATH; FIND_MELD_LOG: proc; call hcs_$make_seg (dn, en, "", 01011b, net_log_ptr, icode); if net_log_ptr = null then goto err_no_meld_log; if net_log_ptr -> net_log_file.max = 0 then do; net_log_ptr -> net_log_file.max = 2047; /* 64 K */ net_log_ptr -> net_log_file.lls = xlls; end; else if ^update_sw then goto err_meld_update; /* we would have appended to existing log */ end FIND_MELD_LOG; COM_ERR: proc; call com_err_ (icode, "meld_log", reason); end COM_ERR; SWITCH_LOG: proc (log_idx); dcl log_idx fixed bin; /* index into log_data structure */ log_data (log_idx).latestp, log_data (log_idx).logp = log_data (log_idx).nextp; log_data (log_idx).nextp = null; if log_data (log_idx).logp = null then return; log_data (log_idx).maxidx = log_data (log_idx).logp -> net_log_file.count; log_data (log_idx).curidx = 1; end SWITCH_LOG; INSERT_LAST_DATE: proc; net_log_ptr -> net_log_file.ttime = net_log_ptr -> net_log_file.array (net_log_ptr -> net_log_file.count).time; end INSERT_LAST_DATE; end meld_log;  net_as_.alm 09/23/77 1036.9rew 09/22/77 1715.0 70065 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** name net_as_ " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " This segment contains a dispatch module for all Network related " Answering Service entries and various data items used by these various " modules. Usually, the data items are ones needed by all Network AS-related " modules. " " Originally created by D. M. Wells, Dec, 1975. " Modified by D. M. Wells, Oct. 76, to add TELNET option information. " Modified by D. M. Wells, Feb. 77, to move more constants into " this data segment. " Modified by D. M. Wells, May, 1977, to convert to new alm format. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " entry as_admin segdef default_line_length segdef default_term_type segdef device_message segdef icp_services segdef log_table_name segdef logger_grace_period entry logger_init entry logger_restart segdef logger_socket_group segdef logger_state entry logger_stop entry logger_test entry net_abort entry net_changemode entry net_detach entry net_detach_new_proc entry net_error_log entry net_event entry net_index entry net_log_ entry net_order entry net_read entry net_state entry net_write entry net_write_force segdef option_initially_desired segdef option_supported segdef ptty_grace_period segdef testing segdef timeout_factor segdef trace_iocb segdef tracing segdef version " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " equ NO_SRVC,0 " just reserves a space in service table equ LOGIN,1 " normal login service equ FTP,2 " FTP service " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Chronological history of Network portion of the Answering Service: " " 1 -- 3/71 -- initial coding by T. Skinner " 2 -- 7/71 -- modifications by E. W. Meyer " 3 -- 3/73 -- Addition of FTP capabilities by K. T. Pogran " 4 -- 7/73 -- Modifications to work on 6180 " 5 -- 2/74 -- Modification for new TELNET by D. M. Wells " 6 -- 7/76 -- Restructuring of state transitions by D. M. Wells " 7 -- 12/76 -- Changed to use Ring1 NCP interfaces and add Suppress " GoAhead and RCTE option support by D. M. Wells " 8 -- 2/77 -- Changed default term type and line length by D. M. " Wells, Feb. 1977. " 9 -- 7/77 -- Changes to use TTT mechanism by D, M. Wells, " July 1977. (Also change to log_tbl version 5.) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " MACRO Definitions: " " dispatch module_name$entry_point " macro dispatch use text callsp &1 &end " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " version: dec 9 even device_message: aci "device",8 option_supported: oct 040000000000 " READ -- (we issue DO/DON'T) oct 042000000000 " WRITE -- (we issue WILL/WON'T) option_initially_desired: oct 040000000000 " READ -- (we issue DO/DON'T) oct 042000000000 " WRITE -- (we issue WILL/WON'T) log_table_name: aci "log_tbl",32 default_term_type: dec 0 " default terminal type for ARPANET is unknown default_line_length: dec 130 " this is historical line length (from MAP's 2741) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " as_admin: dispatch net_as_admin_$as_admin logger_init: dispatch logger_$logger_init logger_restart: dispatch logger_$logger_restart logger_stop: dispatch logger_$logger_stop logger_test: dispatch logger_$logger_test net_abort: dispatch net_tty_io_$net_abort net_changemode: dispatch net_tty_xtach_$net_changemode net_detach: dispatch net_tty_xtach_$net_detach net_detach_new_proc: dispatch net_tty_xtach_$net_detach_new_proc net_error_log: dispatch net_log_$net_error_log net_event: dispatch net_tty_xtach_$net_event net_index: dispatch net_tty_xtach_$net_index net_log_: dispatch net_log_$net_log_ net_order: dispatch net_tty_xtach_$net_order net_read: dispatch net_tty_io_$net_read net_state: dispatch net_tty_xtach_$net_state net_write: dispatch net_tty_io_$net_write_force net_write_force: dispatch net_tty_io_$net_write_force " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " MACRO Definitions: " macro define_icp_socket " service_type,icp_pin,service_name,ptty_bits use text ine &1,NO_SRVC set num_icp_sockets,num_icp_sockets+1 ifend vfd 36/&1 vfd 36/&2 aci "&3",8 vfd 36/&4 dec 0 &end " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set num_icp_sockets,0 icp_services: vfd 36/contact_sockets define_icp_socket LOGIN,23,TELNET,0 define_icp_socket FTP,3,FTP,0 define_icp_socket LOGIN,1,TELNET,0 define_icp_socket NO_SRVC,0,Unused,0 " entry 4 define_icp_socket NO_SRVC,0,Unused,0 " entry 5 define_icp_socket NO_SRVC,0,Unused,0 " entry 6 define_icp_socket NO_SRVC,0,Unused,0 " entry 7 define_icp_socket NO_SRVC,0,Unused,0 " entry 8 define_icp_socket NO_SRVC,0,Unused,0 " entry 9 define_icp_socket NO_SRVC,0,Unused,0 " entry 10 set contact_sockets,num_icp_sockets " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef ftp_login_responder ftp_login_responder: dec 44 aci ">system_library_network>ftp_server_overseer_",168 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " use static logger_grace_period: dec 20 ptty_grace_period: dec 60 logger_socket_group: dec 0 logger_state: dec 0 testing: dec 0 timeout_factor: dec 1 tracing: dec 0 even trace_iocb: its -1,1 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " join /text/text join /link/static end  net_as_admin_.pl1 09/23/77 1036.9rew 09/22/77 1715.0 86949 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_as_admin_: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (num_args fixed binary (17), tabl_indx fixed binary (17), arg_length fixed binary (24), err_code fixed binary (35), arg_list_ptr pointer, iocb_ptr pointer, arg_ptr pointer) automatic; declare abort_command variable entry options (variable) initial (abort_command_invocation) automatic; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare command_table (0 : 4) character (64) internal static options (constant) initial ( "?", "start reestablish network services after stop.", "stop disallow network dialups.", "+test enable or disable testing environment.", "+trace enable or disable function tracing."); declare PROG character (32) varying initial ("AS-net") internal static options (constant); /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */ declare based_argument character (arg_length) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare (net_as_$timeout_factor fixed binary (17), net_as_$logger_socket_group fixed binary (24), net_as_$testing bit (1) aligned, net_as_$tracing bit (36) aligned, net_as_$trace_iocb pointer) external static; declare 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), ioa_ constant entry options (variable), iox_$find_iocb constant entry (char (*), ptr, fixed bin (35)), logger_$logger_restart constant entry (), logger_$logger_stop constant entry (); declare (hbound, lbound, substr) builtin; /* * * * * STACK REFERENCES * * * * * * * * * * */ declare error condition; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ as_admin: entry (); err_code = 0; call cu_$arg_count (num_args); if num_args < 2 then do; call ioa_ ("Usage is:^/^5xnet command -args-^/Type ? for a list of commands."); return; end; arg_list_ptr = cu_$arg_list_ptr (); if ^ got_argument (-1) then call abort_command (err_code, PROG, "First argument must be ""net""."); if ^ got_argument (0) then call abort_command (err_code, PROG, "Usage is: net command -args-"); do tabl_indx = lbound (command_table, 1) by 1 to hbound (command_table, 1) while (substr (command_table (tabl_indx), 1, 16) ^= arg_ptr -> based_argument); end; if tabl_indx > hbound (command_table, 1) then call abort_command (0, PROG, "Unrecognized command: ^a", arg_ptr -> based_argument); goto handle_command (tabl_indx); /* * * * * * * * * * * * * * * * * * * */ handle_command (0): /* ? - print summary of commands */ call ioa_ ("Network-related commands are:"); do tabl_indx = lbound (command_table, 1) by 1 to hbound (command_table, 1); if substr (command_table (tabl_indx), 1, 1) ^= "+" then call ioa_ ("^3x^a", command_table (tabl_indx)); end; call ioa_ (""); return; /* * * * * * * * * * * * * * * * * * * */ handle_command (1): /* start -- restart Network services */ call logger_$logger_restart (); return; /* * * * * * * * * * * * * * * * * * * */ handle_command (2): /* stop -- stop listening for Network dialups */ call logger_$logger_stop (); return; /* * * * * * * * * * * * * * * * * * * */ handle_command (3): /* +test -- turn on testing environment for Net-AS */ if ^ got_argument (1) then do; net_as_$logger_socket_group = 63; net_as_$timeout_factor = 10; net_as_$testing = "1"b; return; end; if arg_ptr -> based_argument = "-on" then do; net_as_$logger_socket_group = 63; net_as_$timeout_factor = 10; net_as_$testing = "1"b; end; else if arg_ptr -> based_argument = "-off" then do; net_as_$logger_socket_group = 0; net_as_$timeout_factor = 1; net_as_$testing = "0"b; end; else call abort_command (error_table_$badopt, PROG, "The test function requires either ""-on"" or ""-off""."); return; /* * * * * * * * * * * * * * * * * * * */ handle_command (4): /* +trace -- turn on tracing for network portion of AS */ if ^ got_argument (1) then do; net_as_$trace_iocb = iox_$user_output; net_as_$tracing = (36)"1"b; return; end; if arg_ptr -> based_argument = "-off" then do; net_as_$tracing = ""b; return; end; if arg_ptr -> based_argument ^= "-on" then call abort_command (error_table_$badopt, PROG, "Only ""-on"" and ""-off"" are valid arguments to +trace."); if ^ got_argument (2) then do; net_as_$trace_iocb = iox_$user_output; net_as_$tracing = (36)"1"b; return; end; call iox_$find_iocb (arg_ptr -> based_argument, iocb_ptr, err_code); if err_code ^= 0 then call abort_command (err_code, PROG, arg_ptr -> based_argument); net_as_$trace_iocb = iocb_ptr; net_as_$tracing = (36)"1"b; return; /* * * * * * * * * * * * * * * * * * */ return_to_caller: return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* The argument number refered to in this subroutine */ /* is the argument to the function. Thus the "net" that */ /* is required is the -1th arg, and the desired function */ /* is the 0th argument. Thus, the argument numbers refer */ /* to the argument number relatvie to the function. */ 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 + 2, arg_ptr, arg_length, err_code, 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 */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 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 net_as_admin_ */ end;  net_converter_.pl1 10/03/77 1118.7rew 10/03/77 0930.0 66735 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_converter_$to_nine: proc (in_pr, nelem, nelemt, out_pr, onelem, onelemt, flags, code); /* This entry converts network ascii code into Multics ascii code */ /* coded on 110970 by Edwin W. Meyer, Jr. */ /* pirated and entries renamed for test purposes by MAP, 5/13/71 */ /* souped-up for speed, half_sw capability, and escapes by CDT 8/7/72 */ dcl in_pr ptr, /* pointer to input data (input) */ onechar char (1), onecharb bit (9), unspec builtin, string builtin, substr builtin, char_template based char (65536), nelem fixed bin, /* no. characters input. (input) */ nelemt fixed bin, /* no. characters converted. (output) */ out_pr ptr, /* pointer to output area. (input) */ onelem fixed bin, /* character length of output area. (input) */ onelemt fixed bin, /* no. characters output. (output) */ code fixed bin; /* error code. (output) */ dcl (i, /* iterative index over nelem */ j, /* output index, goes to onelemt */ k, /* temp */ n, /* internal copy of nelem */ on) fixed bin; /* internal copy of onelem */ dcl (ipr, /* internal copy of in_pr */ opr) ptr; /* internal copy of out_pr */ dcl inbit bit (8); /* temporary cell */ dcl 1 flags aligned parameter, 2 (can_sw, erkl_sw, esc_sw, half_sw, edit_sw) bit (1) unaligned, 2 pad bit (31) unaligned, 2 (cr_seen, escape_seen) bit (1) unaligned; dcl (lf initial ("00001010"b), escape initial ("01011100"b), cr initial ("00001101"b), red_shift initial ("00001110"b), black_shift initial ("00001111"b), backspace initial ("00001000"b), grave initial ("01100000"b), rbrace initial ("01111101"b), lbrace initial ("01111011"b), vert_bar initial ("01111100"b), tilde initial ("01111110"b), apostrophe initial ("00100111"b), lparen initial ("00101000"b), rparen initial ("00101001"b), exc_pt initial ("00100001"b), equals initial ("00111101"b), null_ch initial ("00000000"b)) bit (8) static; dcl (A initial (65), Z initial (90)) fixed bin static; dcl zeropref bit (5) static initial ("00110"b); dcl bitstring bit (1000) based; dcl (xmit_sw, uswitch) bit (1) aligned internal static initial (""b); dcl 1 xform unaligned static, /* "1"b if char is garbage */ 2 strg1 bit (14) initial ("11111110000000"b), /* chars up to CR */ 2 strg2 bit (18) initial ("111111111111111111"b), 2 strg3 bit (96) initial ((96)"0"b), 2 strg4 bit (128) initial ((128) "1"b); dcl 1 specials unaligned static, /* "1"b if char is special half_sw escape */ 2 strg1 bit (32) initial (""b), /* chars up to CR */ 2 strg2 bit (33) initial ((33)"0"b), 2 strg3 bit (26) initial ((26)"1"b), 2 strg4 bit (5) initial (""b), 2 strg5 bit (27) initial ("100000000000000000000000000"b), 2 strg6 bit (4) initial ("1111"b), 2 strg7 bit (129) initial ((129) "0"b); dcl binary builtin; ipr = in_pr; opr = out_pr; n = nelem * 8; on = onelem * 9; i = -7; j = -8; imp_to_mult: if i + 7 >= n then goto im_return; if j + 8 >= on then goto im_return; i = i + 8; inbit = substr (ipr -> bitstring, i, 8); if binary (inbit) > 127 then goto imp_to_mult; /* ignore all Telnet control chars (those >= 200) */ if inbit = escape then escape_seen = ^escape_seen; if inbit = cr then do; /* Special protocol on cr vs. cr/lf */ cr_seen = "1"b; go to imp_to_mult; end; if cr_seen then do; if inbit = cr then go to put_in_cr; else cr_seen = ""b; if inbit = lf then; else if inbit = null_ch then inbit = cr; else do; put_in_cr: if j + 17 >= on then go to back_down; substr (opr -> bitstring, j, 9) = cr; j = j + 9; end; end; if escape_seen then go to insert; if half_sw then do; k = binary (inbit); if (k >= A & k <= Z) then inbit = inbit | "001"b; /* to lower case */ end; insert: if inbit ^= escape then escape_seen = ""b; j = j + 9; substr (opr -> bitstring, j, 9) = "0"b || inbit; goto imp_to_mult; back_down: i = i - 8; /* i is nelem + 8 after end of "do" loop */ im_return: onelemt = divide (j + 8, 9, 17, 0); nelemt = divide (i + 7, 8, 17, 0); code = 0; return; net_converter_$to_eight: entry (in_pr, nelem, nelemt, out_pr, onelem, onelemt, flags, code); /* This entry converts Multics ascii code into network ascii */ ipr = in_pr; opr = out_pr; n = nelem; on = onelem * 8; i = 0; j = -7; mult_to_imp: if i >= n then goto mi_return; if j + 7 >= on then goto mi_return; i = i + 1; onechar = substr (ipr -> char_template, i, 1); /* to get around oob caused when trying to */ inbit = substr (unspec (onechar), 2); /* read from last word of a segment */ if unspec (onechar) & "1"b then go to non_ascii; if uswitch then if inbit = "11011011"b then goto mi_return; /* 333 is xmit immediate code */ else go to nocheck_ustuff; else if half_sw then if substr (string (specials), binary (inbit) + 1, 1) then go to half_esc_out; if substr (string (xform), binary (inbit) + 1, 1) then do; non_ascii: if edit_sw then go to mult_to_imp; if inbit = red_shift then go to mult_to_imp; if inbit = black_shift then go to mult_to_imp; if j + 40 >= on then go to back_down; onecharb = unspec (onechar); substr (opr -> bitstring, j + 8, 8) = escape; substr (opr -> bitstring, j + 16, 8) = zeropref || substr (onecharb, 1, 3); substr (opr -> bitstring, j + 24, 8) = zeropref || substr (onecharb, 4, 3); substr (opr -> bitstring, j + 32, 8) = zeropref || substr (onecharb, 7, 3); j = j + 32; go to mult_to_imp; end; nocheck_ustuff: if inbit = "00001010"b /* NL */ then do; if xmit_sw then goto mi_return; if j + 16 > on then goto back_down; j = j + 8; substr (opr -> bitstring, j, 8) = "00001101"b /* CR */ ; end; insert2: j = j + 8; substr (opr -> bitstring, j, 8) = inbit; if inbit = "00001101"b /* CR */ then if ^xmit_sw then do; /* turn into CR NUL sequence */ j = j + 8; substr (opr -> bitstring, j, 8) = ""b; /* turn into NUL */ end; goto mult_to_imp; half_esc_out: if inbit = backspace then go to insert2; if inbit = vert_bar then inbit = exc_pt; else if inbit = grave then inbit = apostrophe; else if inbit = lbrace then inbit = lparen; else if inbit = rbrace then inbit = rparen; else if inbit = tilde then inbit = equals; else if edit_sw then go to insert2; j = j + 8; substr (opr -> bitstring, j, 8) = escape; go to insert2; mi_return: onelemt = divide (j + 7, 8, 17, 0); nelemt = i; code = 0; return; xmit_on: entry; /* To turn on xmit immediate mode */ xmit_sw = "1"b; return; xmit_off: entry; /* To turn off xmit immediate mode */ xmit_sw = ""b; return; umode_on: entry; uswitch = "1"b; return; umode_off: entry; uswitch = ""b; return; end net_converter_$to_nine;  net_log_.pl1 09/23/77 1036.9rew 09/22/77 1715.0 85446 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_log_: proc (severity); /* NET_LOG_ - procedure to do error reporting and logging for answering service. call net_log_ (severity, control_string, args...); "severity" tells whether to type or log as follows . -8 type message with no newline . -100 type message on operators' console . -2 type message with banner . -1 type message . 0 log message . 1 log & type message . 2 log & type message with banner . 100 log & type message on operators' console Stolen as verbatim as possible from sys_log_ by C. D. Tavares 6/21/72 with apologies to... THVV 11/70 */ dcl severity fixed bin; /* First arg. How bad things are. */ dcl rb (3) fixed bin (3), get_ring_ ext entry returns (fixed bin (3)), tname char (32), hcs_$acl_add1 ext entry (char (*), char (*), char (*), fixed bin, (3) fixed bin (3), fixed bin (35)); dcl lin char (120), /* formatted line */ xlls char (12) aligned int static init (""), /* name of previous seg */ lin1 char (120) aligned, /* temp formatted line */ short char (8) aligned, /* not used */ long char (100) aligned, /* explanation of err code from error_table */ dtime fixed bin (71), /* time of call */ xsv fixed bin, /* copy of severity */ timestr char (16), /* converted time: mm/dd/yy hhmm.s */ save_date char (8) aligned int static init (""), /* date, to see if to print */ ptime char (16) aligned, /* date & time printed */ user_info_$homedir ext entry (char (*)), en char (32) int static init ("net_log"), /* path name of system net_log file */ old_name char (32), /* old filename, when we rename */ n fixed bin, /* temp */ i fixed bin, /* temp */ net_log_ptr ptr int static init (null), /* ptr to log file */ BEL char (1) aligned int static initial (""), /* bell char */ err_code fixed bin (35); /* error code for file system */ dcl (addr, length, null, substr) builtin; dcl formline_ entry options (variable), /* internal system line-formatter */ check_fs_errcode_ entry (fixed bin (35), char (8) aligned, char (100) aligned), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35)), ipc_$mask_ev_calls entry (fixed bin (35)), /* so no answering-service interruption while typing */ ipc_$unmask_ev_calls entry (fixed bin (35)), /* ... */ phcs_$ring_0_message entry (char (*)), /* talk to operator */ clock_ entry returns (fixed bin (71)), /* the system clock */ ioa_ entry options (variable), ioa_$rsnnl entry options (variable), ioa_$nnl entry options (variable), date_time_ entry (fixed bin (71), char (*)); %include netlog; /* - - - - - - - - - - - */ n = length (lin1); call formline_ (2, 3, addr (lin1), n, 0); /* looks at arg2 for format */ lin = substr (lin1, 1, n); /* cure formline problem, trailing nulls */ go to join; net_error_log: entry (severity, errtype, callername); /* like com_err_ for initializer */ dcl errtype fixed bin (35), callername char (*); long = ""; /* blank reason */ if errtype ^= 0 /* convert user error code to string */ then call check_fs_errcode_ (errtype, short, long); /* find explanation of errcode */ n = length (lin1); call formline_ (4, 5, addr (lin1), n, 0); /* format string is arg 4 */ call ioa_$rsnnl ("^a: ^a ^a", lin, i, callername, long, substr (lin1, 1, n)); n = i; /* now have nice message */ join: xsv = severity; /* copy severity */ dtime = clock_ (); /* get clock time */ call date_time_ (dtime, timestr); /* format it up */ if xsv < 0 then do; /* not logging? */ xsv = -xsv; /* make positive */ go to pr; end; else do; if net_log_ptr = null then do; /* Here if writing into file */ if ^ find_log_segment () then goto pr; end; if net_log_ptr -> net_log_file.count >= net_log_ptr -> net_log_file.max then do; xlls = substr (timestr, 11, 4) || "-" || substr (timestr, 1, 5); old_name = "net_log.-." || xlls; call hcs_$chname_seg (net_log_ptr, en, old_name, err_code); if err_code ^= 0 then go to pr; /* can't happen */ call hcs_$terminate_noname (net_log_ptr, (0)); if ^ find_log_segment () then goto pr; /* now make new segment */ end; net_log_ptr -> net_log_file.count = net_log_ptr -> net_log_file.count + 1; /* increase count */ net_log_ptr -> net_log_file.ttime = dtime; /* set last-time-logged */ i = net_log_ptr -> net_log_file.count; /* get into XR */ net_log_ptr -> net_log_file.time (i) = dtime; /* set time of message */ net_log_ptr -> net_log_file.svty (i) = xsv; /* ... severity */ net_log_ptr -> net_log_file.line (i) = lin; /* ... formatted line */ if xsv = 0 then return; /* just logging? */ end; pr: call ipc_$mask_ev_calls (err_code); /* so no event channels go off it ttydim blocks */ if (xsv > 1) & (xsv < 100) then call ioa_ ("^a^a^a^a^a^a**********^R", BEL, BEL, BEL, BEL, BEL, BEL); if substr (timestr, 1, 8) ^= save_date then do; /* has date changed? */ save_date = substr (timestr, 1, 8); /* yes */ ptime = timestr; end; else ptime = substr (timestr, 11, 6); /* same date */ if xsv = 8 then call ioa_$nnl ("^a ^a ", ptime, substr (lin, 1, n)); else if xsv = 100 then call phcs_$ring_0_message (lin); /* blast operators' console */ else call ioa_ ("^a ^a", ptime, lin); /* print message */ if (xsv > 1) & (xsv < 100) /* midnight, cinderella */ then call ioa_ ("^B**********^a^a^a^a^a^a^a^a^a^a^a^a^/", BEL, BEL, BEL, BEL, BEL, BEL, BEL, BEL, BEL, BEL, BEL, BEL); call ipc_$unmask_ev_calls (err_code); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ find_log_segment: procedure () returns (bit (1)); /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ declare (initialized bit (1) initial ("0"b), dir_name character (168) initial ("")) internal static; /* * * * * * * * * * * * * * * * * * * * * * * * */ if ^ initialized then do; call user_info_$homedir (dir_name); initialized = "1"b; end; call hcs_$make_seg (dir_name, en, "", 1011b, net_log_ptr, err_code); if net_log_ptr = null () then return ("0"b); rb (1), rb (2), rb (3) = get_ring_(); do tname = "*.CompNet.*", "*.NetAdmin.*", "Network_Daemon.*.*"; call hcs_$acl_add1 (dir_name, en, tname, 1011b, rb, err_code); end; if net_log_ptr -> net_log_file.max = 0 then do; /* new segment? */ net_log_ptr -> net_log_file.max = 2047; /* 64K segment */ net_log_ptr -> net_log_file.lls = xlls; /* save name of old one */ end; return ("1"b); end; /* end find_log_segment */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end net_log_ */ end;  net_tty_io_.pl1 07/18/80 1703.1rew 07/18/80 1255.2 161244 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_tty_io_: procedure (); /* This module provides the actual Input/Output functions for the */ /* Network Answering Service pseudo-TTY support. This module is */ /* directly responsible for doing formating of output and */ /* canonicalization of input. */ /* Initially coded by T. Skinner, March 16, 1971. */ /* Modified by Ken Pogran 3/11/73 for FTP transmogrification. */ /* Almost enitrely rewritten by D. M. Wells, October 1975, to get around */ /* problems caused by new AS interface to pseudo-TTYs. */ /* Modified by D. M. Wells, August 1976, to support xmog order calls. */ /* Modified by D. M. Wells, October 1976, to use ring1 NCP interface and */ /* to add support for various TELNET negotiated options. */ /* Modified by D. M. Wells, April, 1977, to remove transmogrifier. */ /* Modified by D. M. Wells, Sept. 1977, to add doc and to comment out */ /* code that would eliminiate trailing spaces. This function is */ /* now done by the AS itself. */ /* Modified May 1980 by C. Hornig to avoid sending wakeups to the AS */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare ( P_abortflag fixed binary (3), P_state fixed binary (4), P_ptty_indx fixed binary (17), /* index of channel in network logger table */ (P_ws_offset, P_nelem, P_nelemt) fixed binary (24), P_error_code fixed binary (35), P_wksp_ptr pointer, P_lt_ptr pointer, P_log_tbl_ptr pointer ) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ( nstate fixed binary (6), (indx, loop_count) fixed binary (17), (it, next_pos, nl_pos, num_cvt, num_xmt, our_nelem) fixed binary (24), ierr_code fixed binary (35), space (0:1099) bit (8) unaligned, (ip, ltp, mode_ptr, opr) pointer ) automatic; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ declare logp pointer initial (null ()) internal static; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare PROG character (32) varying initial ("net_tty_io_") internal static options (constant); declare ( NL initial (" "), CR initial (" ") ) character (1) internal static options (constant); /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare ( modebits_4 bit (4) aligned, modebits_72 bit (72) aligned, dumc (0:162144) character (1), dums character (262144), based_message character (our_nelem) ) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare ( net_as_$tracing bit (36) aligned, net_as_$trace_iocb pointer ) external static; declare ( error_table_$bad_index, error_table_$device_not_usable, error_table_$invalid_state, error_table_$net_invalid_state, error_table_$net_not_up, error_table_$net_socket_closed, error_table_$not_attached ) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare canonicalizer_ constant entry (ptr, fixed bin (24), ptr, fixed bin (24), fixed bin (24), bit (4) aligned, fixed bin (35)), ioa_$ioa_switch constant entry options (variable), ncp_$read_data constant entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), ncp_$write_data constant entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), net_converter_$to_eight constant entry (ptr, fixed bin (24), fixed bin (24), ptr, fixed bin (24), fixed bin (24), bit (72) aligned, fixed bin (35)), net_converter_$to_nine constant entry (ptr, fixed bin (24), fixed bin (24), ptr, fixed bin (24), fixed bin (24), bit (72) aligned, fixed bin (35)), net_log_$net_error_log constant entry options (variable), net_tty_modes_$get_modes_from_NCP constant entry (ptr, fixed bin (35)), net_tty_telnet_$interpret_received_protocol constant entry (ptr, ptr, fixed bin (24), fixed bin (35)), net_tty_telnet_$issue_AO constant entry (ptr, fixed bin (35)), net_tty_telnet_$issue_GA constant entry (ptr, fixed bin (35)), net_tty_telnet_$issue_synch constant entry (ptr, fixed bin (35)), net_tty_xtach_$close_pseudo_tty constant entry (fixed bin (17), fixed bin (35)), net_tty_xtach_$net_report_down constant entry (fixed bin (35)); declare (addr, dimension, hbound, length, string, substr) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ %include log_tbl; %include net_as_states; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ net_tty_io_init: entry (P_log_tbl_ptr, P_error_code); P_error_code = 0; logp = P_log_tbl_ptr; return; /* * * * * * * * * * * * * * * * * * * * * * * */ net_abort: entry (P_ptty_indx, P_abortflag, P_state, P_error_code); ltp = find_pseudo_tty (P_ptty_indx, "abort", P_state, P_error_code); if (P_abortflag = 1) | (P_abortflag = 3) /* caller wants a resetread */ then do; if ltp -> lt.using_new_TELNET then call net_tty_telnet_$issue_AO (ltp, (0)); ltp -> lt.bufidx = 0; call net_read (P_ptty_indx, addr (space), 0, 100, (0), P_state, (0)); ltp -> lt.bufidx = 0; end; if (P_abortflag = 2) | (P_abortflag = 3) /* caller wants a resetwrite */ then do; if ltp -> lt.using_new_TELNET then call net_tty_telnet_$issue_synch (ltp, ierr_code); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_write_force: entry (P_ptty_indx, P_wksp_ptr, P_ws_offset, P_nelem, P_nelemt, P_state, P_error_code); P_nelemt = 0; ltp = find_pseudo_tty (P_ptty_indx, "write", P_state, P_error_code); if ltp -> lt.tty_state ^= TTY_DIALED then do; P_error_code = error_table_$invalid_state; return; end; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: (write-force) ""^a"".", PROG, substr (P_wksp_ptr -> dums, P_ws_offset + 1, P_nelem)); if ltp -> lt.line_state = LINE_UP_CONTROL then call net_tty_modes_$get_modes_from_NCP (ltp, (0)); mode_ptr = addr (ltp -> lt.current_modes); our_nelem = P_nelem; /* copy num of chars into our temp variable */ /* if (our_nelem > length (temp_string)) | (our_nelem < 3) */ /* then do; /* can't check this size for trailing whitespace */ ip = addr (P_wksp_ptr -> dumc (P_ws_offset)); /* get pointer to actual start of string */ /* end; */ /* else do; */ /* substr (temp_string, 1, our_nelem) = substr (P_wksp_ptr -> dums, P_ws_offset + 1, our_nelem); */ /* ip = addr (temp_string); */ /* /* The following code will eliminate any */ /* /* trailing spaces on the line sent to us by the */ /* /* dialup procedure. */ /* if substr (temp_string, our_nelem, 1) = NL */ /* then if substr (temp_string, our_nelem - 1, 1) = " " */ /* then do; */ /* do our_nelem = our_nelem - 3 by -1 to 1 */ /* while (substr (temp_string, our_nelem + 1, 1) = " "); */ /* end; */ /* substr (temp_string, our_nelem + 2, 1) = NL; */ /* our_nelem = our_nelem + 2; */ /* end; */ /* end; */ call write_ascii (ip -> based_message); P_nelemt = P_nelem; /* if we get to here, then all the data was taken */ if ltp -> lt.rcte_in_effect then if ltp -> lt.waiting_for_break_char /* this is spontaneous output */ then do; /* call net_tty_telnet_$issue_RCTE_SB (ltp, 0, P_error_code); */ /* RCTE has been changed to not want this anymore */ end; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_read: entry (P_ptty_indx, P_wksp_ptr, P_ws_offset, P_nelem, P_nelemt, P_state, P_error_code); P_nelemt = 0; ltp = find_pseudo_tty (P_ptty_indx, "read", P_state, P_error_code); if ltp -> lt.tty_state ^= TTY_DIALED then do; /* we ought to be talking to a dialed up channel */ P_error_code = error_table_$invalid_state; return; end; mode_ptr = addr (ltp -> lt.current_modes); /* call the NCP to read data */ read_from_ncp: do loop_count = 0 by 1 to 200; call ncp_$read_data (ltp -> lt.sock_handle (READ), addr (space), dimension (space, 1), num_xmt, nstate, ierr_code); if (ierr_code ^= 0) | (nstate ^= 6) then do; if socket_is_closed (ierr_code, P_state) then return; call report_socket_error (ierr_code, "ncp_read", P_state); return; end; if num_xmt = 0 then do; call net_tty_telnet_$issue_GA (ltp, ierr_code); return; end; call net_tty_telnet_$interpret_received_protocol (ltp, addr (space), num_xmt, ierr_code); next_pos = ltp -> lt.bufidx + 1; call net_converter_$to_nine (addr (space), num_xmt, it, addr (ltp -> lt.buf (next_pos)), 121 - next_pos, num_cvt, mode_ptr -> modebits_72, ierr_code); if (ierr_code ^= 0) | (num_xmt ^= it) then do; call report_socket_error (ierr_code, "net_converter_9", P_state); return; end; ltp -> lt.bufidx = ltp -> lt.bufidx + num_cvt; do nl_pos = 1 to ltp -> lt.bufidx; if ltp -> lt.buf (nl_pos) = NL then goto full_line; end; end; call report_socket_error (ierr_code, "readloop", P_state); return; full_line: if string (ltp -> lt.telnet_state) ^= ""b then goto read_from_ncp; /* if any telnet stuff pending, pretend that didnt get a full line */ if string (ltp -> lt.option_in_negotiation (READ)) ^= ""b then goto read_from_ncp; if string (ltp -> lt.option_in_negotiation (WRITE)) ^= ""b then goto read_from_ncp; num_cvt = nl_pos; if nl_pos > 0 then if ltp -> lt.buf (nl_pos - 1) = CR then do; nl_pos = nl_pos - 1; ltp -> lt.buf (nl_pos) = NL; end; opr = addr (P_wksp_ptr -> dumc (P_ws_offset)); call canonicalizer_ (addr (ltp -> lt.buf), nl_pos, opr, P_nelem, P_nelemt, mode_ptr -> modebits_4, ierr_code); if ierr_code ^= 0 then do; call report_socket_error (ierr_code, "canonica", P_state); return; end; ltp -> lt.bufidx = ltp -> lt.bufidx - num_cvt; do indx = 1 by 1 to ltp -> lt.bufidx; /* move down any remaining data */ ltp -> lt.buf (indx) = ltp -> lt.buf (indx + num_cvt); end; do indx = ltp -> lt.bufidx + 2 to hbound (ltp -> lt.buf, 1); ltp -> lt.buf (indx) = ""; end; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: (read) ""^a"".", PROG, substr (P_wksp_ptr -> dums, P_ws_offset + 1, P_nelemt)); ltp -> lt.need_Go_Ahead = "1"b; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ write_TELNET_bytes: entry (P_lt_ptr, P_wksp_ptr, P_nelem, P_error_code); P_error_code = 0; ltp = P_lt_ptr; call write_to_NCP (P_wksp_ptr, P_nelem, (0)); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ write_ascii: procedure (p_ascii_message); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_ascii_message character (*) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ( (num_converted, num_elemt) fixed binary (24), bit8_array (0:1099) bit (8) ) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call net_converter_$to_eight (addr (p_ascii_message), length (p_ascii_message), num_elemt, addr (bit8_array), dimension (bit8_array, 1), num_converted, mode_ptr -> modebits_72, ierr_code); if ierr_code ^= 0 then do; call report_socket_error (ierr_code, "net_converter_8", P_state); return; end; if length (p_ascii_message) ^= num_elemt then do; call report_socket_error (ierr_code, "t8_nelem", P_state); return; end; call write_to_NCP (addr (bit8_array), num_converted, P_state); return; end; /* end write_ascii */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ write_to_NCP: procedure (p_wksp_ptr, p_wksp_len, p_state); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare ( p_state fixed binary (4), p_wksp_len fixed binary (24), p_wksp_ptr pointer ) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare num_sent fixed binary (24) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call ncp_$write_data (ltp -> lt.sock_handle (WRITE), p_wksp_ptr, p_wksp_len, num_sent, nstate, ierr_code); if (ierr_code ^= 0) | (nstate ^= 6) then do; if socket_is_closed (ierr_code, p_state) then goto call_finish; call report_socket_error (ierr_code, "wr_force", p_state); goto call_finish; end; if num_sent ^= p_wksp_len then do; call report_socket_error (ierr_code, "wf_nelem", p_state); goto call_finish; end; return; end; /* end write_to_NCP */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ socket_is_closed: procedure (p_code, p_state) returns (bit (1)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare ( p_state fixed binary (4), p_code fixed binary (35) ) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (p_code = 0) | (p_code = error_table_$net_invalid_state) | (p_code = error_table_$net_socket_closed) then do; call clear_connection (); p_state = ltp -> lt.tty_state; return ("1"b); end; p_state = ltp -> lt.tty_state; return ("0"b); end; /* end socket_is_closed */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ find_pseudo_tty: procedure (p_tty_indx, p_function, p_state, p_err_code) returns (ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare ( p_state fixed binary (4), p_tty_indx fixed binary (17), p_err_code fixed binary (35), p_function character (*) ) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare tty_indx fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Entering, ^a for ^d.", PROG, p_function, p_tty_indx); p_err_code = 0; p_state = 0; tty_indx = p_tty_indx; if (tty_indx <= 0) | (tty_indx > logp -> ltbl.max_inuse) then do; p_err_code = error_table_$bad_index; goto call_finish; end; if logp -> ltbl.entry (tty_indx).active ^= PTTY_attached then do; if logp -> ltbl.entry (tty_indx).active = PTTY_detached then p_err_code = error_table_$not_attached; else p_err_code = error_table_$device_not_usable; goto call_finish; end; p_state = logp -> ltbl.entry (tty_indx).tty_state; return (addr (logp -> ltbl.entry (p_tty_indx))); end; /* end find_pseudo_tty */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ clear_connection: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ call net_tty_xtach_$close_pseudo_tty (ltp -> lt.tty_index, (0)); return; end; /* end clear_connection */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ report_socket_error: procedure (p_code, p_explanation, p_state); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare ( p_state fixed binary (4), p_code fixed binary (35), p_explanation character (*) ) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: reporting socket error ^a", PROG, p_explanation); call clear_connection (); p_state = ltp -> lt.tty_state; call net_log_$net_error_log (0, p_code, PROG, "Error '^a' for ^a from ^a", p_explanation, ltp -> lt.tty_name, ltp -> lt.hostname); if p_code = error_table_$net_not_up then do; call net_tty_xtach_$net_report_down ((0)); goto call_finish; end; call clear_connection (); return; end; /* end report_socket_error */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call_finish: return; /* BEGIN MESSAGE DOCUMENTATION Message: net_tty_io_: ERROR-MESSAGE Error 'EXPLANATION' for TTY-NAME from HOST S: net-as (severity0) T: $run M: The ARPANET Answering Service software detected a problem with TTY channel TTY-NAME, which was connected to host HOST. A: $ignore The channel has been hungup and reinitialized. END MESSAGE DOCUMENTATION */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end net_tty_io_ */  net_tty_modes_.pl1 10/03/77 1118.7rew 10/03/77 0930.0 128844 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_tty_modes_: procedure (); /* This module is part of the Network Answering Service pseudo-TTY */ /* support. It is directly responsible for interpreting modes string in */ /* changemodes calls and for communicating the state of the modes (and */ /* the TELNET option negotiations) to the user process. */ /* Originally created by D. M. Wells, October 1975. */ /* Modified by D. M. Wells, October, 1976, to add TELNET option */ /* communication to and from user process. */ /* Modified by D. M. Wells, July 1977, to use TTT mechanism. */ /* Modified by D. M. Wells, August 1977 to save state of "half"-ASCII */ /* mode bit over any change_modes call. */ /* Note that the saving of the "half"-ASCII mode bit is done so */ /* that no call to the change-modes entry point can change the state */ /* of the bit. This would be more easily done if the bit were just */ /* moved out of the "current_modes" structure. Unfortunately, the very */ /* old modules net_converter_ and canonicalizer_ use a structure that */ /* looks like the rest of the current_modes structure and that requires */ /* the "half" bit to be in that structure. */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (P_error_code fixed binary (35), (P_new_modes, P_old_modes) character (*), P_lt_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (indx fixed binary (17), ll_temp fixed binary (17), forcing_modes bit (1), tty33_temp bit (1), (newm, oldm) bit (7), ncp_umodes bit (36) aligned, old_modes character (128) varying, ltp pointer) automatic; declare 1 modes_comm automatic like user_AS_modes_comm_template, 1 options_comm automatic like user_AS_options_comm_template; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare (GET_UMODES initial (27), SET_UMODES initial (28)) fixed binary (12) internal static options (constant); declare (modes_by_default_on initial ("1110000"b), modes_by_default_off initial ("0000000"b)) bit (7) internal static options (constant); declare MODE_NAME (7) character (8) varying initial ("can", "erkl", "esc", "", "edited", "hndlquit", "tabs") internal static options (constant); /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */ declare based_fb35 fixed binary (35) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare net_as_$default_line_length fixed binary (17) external static; declare error_table_$bad_mode fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare convert_binary_integer_$decimal_string constant entry (fixed bin (35)) returns (char (12) varying), cv_dec_check_ constant entry (char (*), fixed bin (35)) returns (fixed bin (35)), net_$ncp_order constant entry (bit (36), fixed bin (12), ptr, fixed bin (6), fixed bin (35)), net_mode_parser_ constant entry (char (*), entry (char (*) varying, bit (*), ptr, fixed bin (35)), fixed bin (35)), net_tty_telnet_$update_option_status constant entry (ptr, fixed bin (35)); declare (addr, binary, bit, hbound, lbound, length, string, substr) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include log_tbl; % include net_as_states; % include net_user_as_comm_dcls; % include tty_types; % include ttyp; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_modes_from_NCP: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; call net_$ncp_order (ltp -> lt.sock_handle (WRITE), GET_UMODES, addr (ncp_umodes), (0), P_error_code); if P_error_code ^= 0 then ncp_umodes = ""b; string (modes_comm) = ncp_umodes; ltp -> lt.current_modes.can = "1"b; ltp -> lt.current_modes.erkl = "1"b; ltp -> lt.current_modes.esc = "1"b; ltp -> lt.current_modes.half = modes_comm.mode_switches.half; ltp -> lt.current_modes.edited = modes_comm.mode_switches.edited; ltp -> lt.current_modes.hndlquit = modes_comm.hndlquit; ltp -> lt.current_modes.tabs = modes_comm.mode_switches.tabs; ltp -> lt.old_terminal_type = binary (modes_comm.terminal_type, 17); if ltp -> lt.old_terminal_type = 0 then ltp -> lt.old_terminal_type = TYPE_ASCII; else if ltp -> lt.old_terminal_type = TYPE_TTY33 then ltp -> lt.current_modes.half = "1"b; ltp -> lt.terminal_type_name = tty_dev_type (ltp -> lt.old_terminal_type); ltp -> lt.line_length = binary (modes_comm.line_length, 10); if modes_comm.protocol_info.protocol_15372 then ltp -> lt.using_new_TELNET = "1"b; call net_$ncp_order (ltp -> lt.sock_handle (READ), GET_UMODES, addr (ncp_umodes), (0), P_error_code); if P_error_code ^= 0 then ncp_umodes = ""b; string (options_comm) = ncp_umodes; string (ltp -> lt.option_in_effect (READ)) = string (options_comm.receive_option.in_effect); string (ltp -> lt.option_in_negotiation (READ)) = string (options_comm.receive_option.in_negotiation); string (ltp -> lt.option_in_effect (WRITE)) = string (options_comm.transmit_option.in_effect); string (ltp -> lt.option_in_negotiation (WRITE)) = string (options_comm.transmit_option.in_negotiation); call net_tty_telnet_$update_option_status (ltp, (0)); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ set_modes_in_NCP: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; string (modes_comm) = ""b; modes_comm.mode_switches.can = ltp -> lt.current_modes.can; modes_comm.mode_switches.erkl = ltp -> lt.current_modes.erkl; modes_comm.mode_switches.esc = ltp -> lt.current_modes.esc; modes_comm.mode_switches.half = ltp -> lt.current_modes.half; modes_comm.mode_switches.edited = ltp -> lt.current_modes.edited; modes_comm.mode_switches.hndlquit = "0"b; modes_comm.mode_switches.tabs = ltp -> lt.current_modes.tabs; modes_comm.version_number = bit (binary (user_as_comm_version_2, 4)); if ltp -> lt.old_terminal_type = 0 then modes_comm.terminal_type = bit (binary (TYPE_ASCII, 4)); else modes_comm.terminal_type = bit (binary (ltp -> lt.old_terminal_type, 4)); modes_comm.line_length = bit (binary (ltp -> lt.line_length, 10)); modes_comm.protocol_info.protocol_15372 = ltp -> lt.using_new_TELNET; modes_comm.protocol_info.protocol_17759 = (ltp -> lt.contact_pin = 21); ncp_umodes = string (modes_comm); call net_$ncp_order (ltp -> lt.sock_handle (WRITE), SET_UMODES, addr (ncp_umodes), (0), (0)); string (options_comm.receive_option.in_effect) = string (ltp -> lt.option_in_effect (READ)); string (options_comm.receive_option.in_negotiation) = string (ltp -> lt.option_in_negotiation (READ)); string (options_comm.transmit_option.in_effect) = string (ltp -> lt.option_in_effect (WRITE)); string (options_comm.transmit_option.in_negotiation) = string (ltp -> lt.option_in_negotiation (WRITE)); ncp_umodes = string (options_comm); call net_$ncp_order (ltp -> lt.sock_handle (READ), SET_UMODES, addr (ncp_umodes), (0), P_error_code); if P_error_code ^= 0 then return; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ change_modes: entry (P_lt_ptr, P_new_modes, P_old_modes, P_error_code); P_error_code = 0; ltp = P_lt_ptr; forcing_modes = "0"b; /* by default, we detect unknown mode strings */ newm, oldm = string (ltp -> lt.current_modes); /* get copy of current modes */ tty33_temp = ltp -> lt.half; ll_temp = ltp -> lt.line_length; old_modes = ""; do indx = lbound (MODE_NAME, 1) by 1 to hbound (MODE_NAME, 1); if MODE_NAME (indx) ^= "" then do; if ^ substr (oldm, indx, 1) then old_modes = old_modes || "^"; /* we need to put a ^ before the mode */ old_modes = old_modes || MODE_NAME (indx); /* append the name of this mode */ old_modes = old_modes || ","; /* append the comma before the next mode */ end; end; old_modes = old_modes || "ll" || convert_binary_integer_$decimal_string ((ll_temp)); P_old_modes = old_modes; /* give interpretation of old modes to caller */ call net_mode_parser_ (P_new_modes, interpret_key, P_error_code); if P_error_code ^= 0 then return; string (ltp -> lt.current_modes) = newm; /* only now do we set the new modes into state */ ltp -> lt.half = tty33_temp; /* don't let function alter this bit */ ltp -> lt.line_length = ll_temp; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ interpret_key: procedure (p_key, p_info_bits, p_data_ptr, p_err_code); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_err_code fixed binary (35), p_info_bits bit (*), p_key character (*) varying, p_data_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (mode_indx fixed binary (17), mode_desired_on bit (1), integer_value_exists bit (1)) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ p_err_code = 0; mode_desired_on = "1"b; /* default is to make the mode go on */ integer_value_exists = "0"b; /* default is that no integer was decoded */ if length (p_info_bits) >= 1 then mode_desired_on = substr (p_info_bits, 1, 1); if length (p_info_bits) >= 2 then integer_value_exists = substr (p_info_bits, 2, 1); if p_key = "default" /* if user wants default modes */ then do; newm = (newm & ^ modes_by_default_off) | modes_by_default_on; return; end; if p_key = "init" /* user wants "initial" modes */ then do; newm = ""b; newm = (newm & ^ modes_by_default_off) | modes_by_default_on; ll_temp = net_as_$default_line_length; return; end; if p_key = "ll" then do; if ^ mode_desired_on then ll_temp = 0; else do; ll_temp = p_data_ptr -> based_fb35; if (ll_temp < 10) | (ll_temp > 253) then do; p_err_code = error_table_$bad_mode; return; end; end; return; end; if length (p_key) > 2 then if substr (p_key, 1, 2) = "ll" /* this is line_length mode of form "llxxx" */ then do; ll_temp = cv_dec_check_ (substr (p_key, 3), p_err_code); if (p_err_code ^= 0) | (ll_temp < 10) | (ll_temp > 253) then do; p_err_code = error_table_$bad_mode; return; end; return; end; do mode_indx = lbound (MODE_NAME, 1) by 1 to hbound (MODE_NAME, 1) while (p_key ^= MODE_NAME (mode_indx)); /* search for this mode name in table */ end; if mode_indx <= hbound (MODE_NAME, 1) then do; /* if the search succeeeded, then store bit */ substr (newm, mode_indx, 1) = mode_desired_on; return; end; if p_key = "force" then do; forcing_modes = mode_desired_on; return; end; if forcing_modes then return; /* we are ignoring unknown modes, so return */ p_err_code = error_table_$bad_mode; return; end; /* end interpret_key */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end net_tty_modes_ */ end;  net_tty_telnet_.pl1 09/23/77 1036.9rew 09/22/77 1715.0 279810 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_tty_telnet_: procedure (); /* This module is part of the ARPA Network logger. It is */ /* responsible for knowing about the TELNET protocol used and properly */ /* responding to special commands and option negotiatiosn, etc. */ /* Note in interpreting the option negotiation that, from the local */ /* viewpoint, our "READ" side receives WILLs and WONTs, and transmits */ /* DOs and DONTs. */ /* Originally created by D. M. Wells, Oct, 1976 by splitting it off from */ /* net_tty_io_, where much of it used to be. */ /* Modified by D. M. Wells, April, 1977, to fix RCTE so that it doesn't */ /* include the IAC in its invocation as a break character. */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (P_rcte_cmd fixed binary (8), P_nelem fixed binary (24), P_error_code fixed binary (35), P_wksp_ptr pointer, P_lt_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (rcte_cmd fixed binary (8), nstate fixed binary (6), option_indx fixed binary (8), indx fixed binary (24), ierr_code fixed binary (35), cur_byte bit (9), host_name character (32), ltp pointer) automatic; declare 1 write_buffer aligned automatic, 2 num_bytes fixed binary (24), 2 byte (0 : 31) bit (9) unaligned; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare PROG character (32) varying initial ("net_tty_telnet_") internal static options (constant); declare (NUL initial ("000"b3), BS initial ("010"b3), LF initial ("012"b3), CR initial ("015"b3), num_sign initial ("043"b3), at_sign initial ("100"b3)) bit (9) internal static options (constant); declare (RCTE_set initial (1), RCTE_skip_break initial (2), RCTE_skip_text initial (4), RCTE_break_classes initial (8), RCTE_xmit_classes initial (16)) fixed binary (8) internal static options (constant); /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare net_byte (0 : 1179647) bit (8) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare (net_as_$tracing bit (36) aligned, net_as_$trace_iocb pointer) external static; declare 1 net_as_$option_supported (0: 1) aligned external static, 2 option (0 : 35) bit (1) unaligned; declare 1 net_as_$option_initially_desired (0 : 1) aligned external static, 2 option (0 : 35) bit (1) unaligned; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare convert_binary_integer_$decimal_string constant entry (fixed bin (35)) returns (char (12) varying), host_id_$symbol constant entry (fixed bin (16), char (*), fixed bin (35)), ioa_$ioa_switch constant entry options (variable), ioa_$rs constant entry options (variable), ncp_$send_interrupt constant entry (bit (36), fixed bin (6), fixed bin (35)), net_convert_size_$direct_9_to_8 constant entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (24), ptr, fixed bin (24), fixed bin (24), fixed bin (24), fixed bin (35)), net_tty_io_$net_write_force constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (24), fixed bin (24), fixed bin (4), fixed bin (35)), net_tty_io_$write_TELNET_bytes constant entry (ptr, ptr, fixed bin (24), fixed bin (35)), system_info_$installation_id constant entry (char (*)); declare (addr, binary, bit, dimension, hbound, lbound, null, string, substr) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include log_tbl; % include telnet_options; % include telnet_special_chars; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call_finish: return; /* * * * * * * * * * * * * * * * * * * * * * * * */ issue_GA: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; if string (ltp -> lt.option_in_negotiation (READ)) ^= ""b then return; /* play dead while negotiations in progress */ if string (ltp -> lt.option_in_negotiation (WRITE)) ^= ""b then return; if ltp -> lt.rcte_in_effect then do; /* We have negotiated RCTE option */ if ltp -> lt.rcte_info.waiting_for_break_char then return; if ltp -> lt.rcte_info.printer_on then call issue_RCTE_SB (ltp, RCTE_set, P_error_code); /* echo everything */ else call issue_RCTE_SB (ltp, RCTE_set + RCTE_skip_text + RCTE_skip_break, P_error_code); /* echo nothing */ if P_error_code ^= 0 then return; ltp -> lt.rcte_info.waiting_for_break_char = "1"b; return; end; if ^ ltp -> lt.need_Go_Ahead then return; ltp -> lt.need_Go_Ahead = "0"b; if ltp -> lt.option_in_effect (WRITE).option (OPTION_suppress_ga) then return; /* Suppress Go-Ahead is in effect */ write_buffer.byte (0) = NET_IAC; write_buffer.byte (1) = NET_GA; write_buffer.num_bytes = 2; call write_to_NCP (addr (write_buffer.byte), write_buffer.num_bytes); return; /* * * * * * * * * * * * * * * * * * * * * * * */ issue_RCTE_SB: entry (P_lt_ptr, P_rcte_cmd, P_error_code); P_error_code = 0; ltp = P_lt_ptr; rcte_cmd = P_rcte_cmd; write_buffer.byte (0) = NET_IAC; write_buffer.byte (1) = NET_SB; write_buffer.byte (2) = bit (binary (OPTION_rcte, 9)); if rcte_cmd = 0 then do; /* zero to us means really issue a 0 to user side */ write_buffer.byte (3) = bit (binary (0, 9)); write_buffer.num_bytes = 4; end; else do; if rcte_cmd = -1 /* this is magic flag saying repeat last cmd */ then rcte_cmd = binary (ltp -> lt.last_rcte_echo_cmd, 3); ltp -> lt.last_rcte_echo_cmd = bit (binary (rcte_cmd, 3)); write_buffer.byte (3) = bit (binary (rcte_cmd + RCTE_break_classes, 9)); /* also set breaks */ write_buffer.byte (4) = bit (binary (0, 9)); /* we told user to expect break classes, and here */ write_buffer.byte (5) = bit (binary (8, 9)); /* they are -- class 4 only, however. But notice */ /* the funny shifting due to the fact that only */ /* eight of these nine bits are actually sent. */ write_buffer.num_bytes = 6; end; write_buffer.byte (write_buffer.num_bytes + 0) = NET_IAC; write_buffer.byte (write_buffer.num_bytes + 1) = NET_SE; write_buffer.num_bytes = write_buffer.num_bytes + 2; call write_to_NCP (addr (write_buffer.byte), write_buffer.num_bytes); if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Sending RCTE SB of ^3.3b", PROG, write_buffer.byte (3)); return; /* * * * * * * * * * * * * * * * * * * * * * * */ issue_AO: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; write_buffer.byte (0) = NET_IAC; write_buffer.byte (1) = NET_AO; write_buffer.num_bytes = 2; call write_to_NCP (addr (write_buffer.byte), write_buffer.num_bytes); return; /* * * * * * * * * * * * * * * * * * * * * * * */ issue_synch: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; write_buffer.byte (0) = NET_IAC; write_buffer.byte (1) = NET_DM; write_buffer.num_bytes = 2; call write_to_NCP (addr (write_buffer.byte), write_buffer.num_bytes); call ncp_$send_interrupt (ltp -> lt.sock_handle (WRITE), nstate, ierr_code); return; /* * * * * * * * * * * * * * * * * * * * * * * */ propose_initial_options: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; if ^ ltp -> lt.using_new_TELNET then return; /* we don't propose options if using old protocol */ do option_indx = lbound (net_as_$option_initially_desired.option, 2) by 1 to hbound (net_as_$option_initially_desired.option, 2); if net_as_$option_initially_desired (READ).option (option_indx) then call invoke_option (option_indx, READ); if net_as_$option_initially_desired (WRITE).option (option_indx) then call invoke_option (option_indx, WRITE); end; return; /* * * * * * * * * * * * * * * * * * * * * * * */ update_option_status: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; call disperse_option_states (); return; /* * * * * * * * * * * * * * * * * * * * * * * */ revoke_unsupported_options: entry (P_lt_ptr, P_error_code); P_error_code = 0; ltp = P_lt_ptr; do option_indx = lbound (net_as_$option_supported.option, 2) by 1 to hbound (net_as_$option_supported.option, 2); if ltp -> lt.option_in_effect (READ).option (option_indx) then if ^ net_as_$option_supported (READ).option (option_indx) then call revoke_option (option_indx, READ); if ltp -> lt.option_in_effect (WRITE).option (option_indx) then if ^ net_as_$option_supported (WRITE).option (option_indx) then call revoke_option (option_indx, WRITE); end; return; /* * * * * * * * * * * * * * * * * * * * * * * */ interpret_received_protocol: entry (P_lt_ptr, P_wksp_ptr, P_nelem, P_error_code); P_error_code = 0; ltp = P_lt_ptr; do indx = 0 by 1 to P_nelem -1; cur_byte = "0"b || P_wksp_ptr -> net_byte (indx); if string (ltp -> lt.telnet_state) = ""b then do; if cur_byte = NET_IAC then do; ltp -> lt.using_new_TELNET = "1"b; ltp -> lt.telnet_state.last_was_IAC = "1"b; P_wksp_ptr -> net_byte (indx) = substr (OUR_NOP, 2); end; else do; /* just an ordinary character */ if ltp -> lt.option_in_effect (WRITE).option (OPTION_rcte) then call check_if_rcte_break_char (cur_byte); end; end; else call interpret_protocol (P_wksp_ptr -> net_byte (indx), indx); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ write_to_NCP: procedure (p_wksp_ptr, p_wksp_len); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_wksp_len fixed binary (24), p_wksp_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare temp_buffer (0 : 99) bit (8) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call net_convert_size_$direct_9_to_8 (null (), p_wksp_ptr, 0, p_wksp_len, (0), addr (temp_buffer), 0, dimension (temp_buffer, 1), (0), (0)); call net_tty_io_$write_TELNET_bytes (ltp, addr (temp_buffer), p_wksp_len, P_error_code); if P_error_code ^= 0 then goto call_finish; return; end; /* end write_to_NCP */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_if_rcte_break_char: procedure (p_cur_byte); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_cur_byte bit (9) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * */ if (p_cur_byte >= CR) then return; if (p_cur_byte < BS) & (p_cur_byte ^= NUL) then return; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Received RCTE break char ^3.3b", PROG, p_cur_byte); if (p_cur_byte = LF) then do; ltp -> lt.rcte_info.waiting_for_break_char = "0"b; ltp -> lt.need_Go_Ahead = "1"b; return; end; call issue_RCTE_SB (ltp, -1, (0)); /* this wasn't the break char we wanted */ return; end; /* end check_if_rcte_break_char */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ interpret_protocol: procedure (p_cur_byte, p_byte_loc); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_byte_loc fixed binary (24), p_cur_byte bit (8)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (num_temp_chars fixed binary (24), char_indx fixed binary (24), cur_byte bit (9), installation_id character (32), answer_buffer character (96) aligned) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if ^ ltp -> lt.telnet_state.last_was_IAC then do; if ltp -> lt.rcte_in_effect then call issue_RCTE_SB (ltp, -1, (0)); call option_negotiation (p_cur_byte); return; end; /* At this point, we know that the last character received */ /* was an IAC. Therefore, the next char must be a command. */ ltp -> lt.telnet_state.last_was_IAC = "0"b; /* we have next, so turn off this flag */ cur_byte = "0"b || p_cur_byte; /* get a copy of the TELNET character */ p_cur_byte = substr (OUR_NOP, 2); /* this must be telnet protocol, so mask now */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: received TELNET command ^3.3b", PROG, cur_byte); if cur_byte = NET_IAC then do; p_cur_byte = substr (NET_IAC, 2); return; end; if cur_byte = NET_DO then do; ltp -> lt.telnet_state.last_was_DO = "1"b; return; end; if cur_byte = NET_WILL then do; ltp -> lt.telnet_state.last_was_WILL = "1"b; return; end; if cur_byte = NET_DONT then do; ltp -> lt.telnet_state.last_was_DONT = "1"b; return; end; if cur_byte = NET_WONT then do; ltp -> lt.telnet_state.last_was_WONT = "1"b; return; end; if cur_byte = NET_AYT then do; call system_info_$installation_id (installation_id); call ioa_$rs ("Multics Answering Service; ^a", answer_buffer, num_temp_chars, installation_id); call net_tty_io_$net_write_force (ltp -> lt.tty_index, addr (answer_buffer), 0, num_temp_chars, (0), (0), (0)); call host_id_$symbol (ltp -> lt.host_num, host_name, ierr_code); if ierr_code ^= 0 then host_name = convert_binary_integer_$decimal_string ((ltp -> lt.host_num)); call ioa_$rs ("^a channel ^a connected to socket ^d at host ^a.", answer_buffer, num_temp_chars, ltp -> lt.service_name, ltp -> lt.tty_name, ltp -> lt.socket_num, host_name); call net_tty_io_$net_write_force (ltp -> lt.tty_index, addr (answer_buffer), 0, num_temp_chars, (0), (0), (0)); if string (ltp -> lt.option_in_negotiation (READ)) ^= ""b then do; call ioa_$rs ("Outstanding option negotiation on User to Server connection.", answer_buffer, num_temp_chars); call net_tty_io_$net_write_force (ltp-> lt.tty_index, addr (answer_buffer), 0, num_temp_chars, (0), (0), (0)); end; if string (ltp -> lt.option_in_negotiation (WRITE)) ^= ""b then do; call ioa_$rs ("Outstanding option negotiation on Server to User connection.", answer_buffer, num_temp_chars); call net_tty_io_$net_write_force (ltp -> lt.tty_index, addr (answer_buffer), 0, num_temp_chars, (0), (0), (0)); end; return; end; if cur_byte = NET_AO then do; call issue_synch (ltp, (0)); return; end; if cur_byte = NET_DM then do; ltp -> lt.bufidx = 0; do char_indx = 0 by 1 to p_byte_loc; P_wksp_ptr -> net_byte (char_indx) = substr (OUR_NOP, 2); end; return; end; if cur_byte = NET_EC then do; p_cur_byte = substr (num_sign, 2); return; end; if cur_byte = NET_EL then do; p_cur_byte = substr (at_sign, 2); return; end; return; /* all other chars can be ignored */ /* IP, BRK, NOP, GA */ end; /* end interpret_protocol */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ revoke_option: procedure (p_option_num, p_direction); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_direction fixed binary (1), p_option_num fixed binary (8)) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if p_option_num > hbound (net_as_$option_supported.option, 2) then return; /* not known, can't be currently in effect */ if ^ ltp -> lt.option_in_effect (p_direction).option (p_option_num) then return; if ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) then return; if p_direction = READ then call send_negotiation_string (NET_DONT, p_option_num); else call send_negotiation_string (NET_WONT, p_option_num); ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) = "1"b; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ option_revoked: entry (p_option_num, p_direction); if p_option_num > hbound (net_as_$option_supported.option, 2) then return; /* not known, can't possibly be in effect */ if ^ ltp -> lt.option_in_effect (p_direction).option (p_option_num) then do; if ^ ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) then return; /* this is improper revocation -- ignore it */ /* Otherwise, we have proposed this option, and other host */ /* has decided to refuse the option */ ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) = "0"b; call disperse_option_states (); return; end; /* At this point, the option is currently is effect, but */ /* somebody has decided to flush the option. */ if ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) then do; /* we flushed the option, and this is reply */ ltp -> lt.option_in_effect (p_direction).option (p_option_num) = "0"b; ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) = "0"b; call disperse_option_states (); return; end; /* Other host has decided to flush the option, and we must */ /* acknowledge the revocation and update our tables. */ if p_direction = READ then call send_negotiation_string (NET_DONT, p_option_num); else call send_negotiation_string (NET_WONT, p_option_num); ltp -> lt.option_in_effect (p_direction).option (p_option_num) = "0"b; call disperse_option_states (); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ invoke_option: entry (p_option_num, p_direction); if p_option_num > hbound (net_as_$option_supported.option, 2) then return; /* don't support options outside range */ if ltp -> lt.option_in_effect (p_direction).option (p_option_num) then return; /* the option in already in effect */ if ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) then return; /* we have already asked for the option */ if p_direction = READ then call send_negotiation_string (NET_DO, p_option_num); else call send_negotiation_string (NET_WILL, p_option_num); ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) = "1"b; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ option_invoked: entry (p_option_num, p_direction); if p_option_num > hbound (net_as_$option_supported.option, 2) then do; /* we refuse large numbered options */ if p_direction = READ then call send_negotiation_string (NET_DONT, p_option_num); else call send_negotiation_string (NET_WONT, p_option_num); return; end; if ltp -> lt.option_in_effect (p_direction).option (p_option_num) then return; /* ignore attempts to invoke active option */ if ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) then do; /* we asked for option, foreign host has agreed */ ltp -> lt.option_in_negotiation (p_direction).option (p_option_num) = "0"b; ltp -> lt.option_in_effect (p_direction).option (p_option_num) = "1"b; call disperse_option_states (); return; end; /* Otherwise, the foreign host is offering an option to */ /* us. We must see whether or not we support this option */ if ^ net_as_$option_supported (p_direction).option (p_option_num) then do; if p_direction = READ then call send_negotiation_string (NET_DONT, p_option_num); else call send_negotiation_string (NET_WONT, p_option_num); return; end; if p_direction = READ then call send_negotiation_string (NET_DO, p_option_num); else call send_negotiation_string (NET_WILL, p_option_num); ltp -> lt.option_in_effect (p_direction).option (p_option_num) = "1"b; call disperse_option_states (); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ send_negotiation_string: procedure (p_command, p_option_num); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_option_num fixed binary (8), p_command bit (9)) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Sending TELNET command ^3.3b for option ^d.", PROG, p_command, p_option_num); write_buffer.byte (0) = NET_IAC; write_buffer.byte (1) = p_command; write_buffer.byte (2) = bit (binary (p_option_num, 9)); write_buffer.num_bytes = 3; call write_to_NCP (addr (write_buffer.byte), write_buffer.num_bytes); return; end; /* end send_negotiation_string */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end revoke_option */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* This module is called whenever an option has come into */ /* effect, or been revoked. It is responsible for updating any */ /* secondary variables, and for performing any funny side effects */ /* of the option (or its revocation). */ disperse_option_states: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ if ltp -> lt.rcte_in_effect ^= ltp -> lt.option_in_effect (WRITE).option (OPTION_rcte) then do; /* notice we do this both ways -- in and out */ ltp -> lt.waiting_for_break_char = "0"b; ltp -> lt.rcte_in_effect = ltp -> lt.option_in_effect (WRITE).option (OPTION_rcte); end; if ltp -> lt.option_in_effect (READ).option (OPTION_timing_mark) then do; /* funny option -- if on, turn it off */ ltp -> lt.option_in_effect (READ).option (OPTION_timing_mark) = "0"b; end; if ltp -> lt.option_in_effect (WRITE).option (OPTION_timing_mark) then do; /* funny option-- if on, turn it back off */ ltp -> lt.option_in_effect (WRITE).option (OPTION_timing_mark) = "0"b; end; return; end; /* end disperse_option_states */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ option_negotiation: procedure (p_cur_byte); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_cur_byte bit (8) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare option_num fixed binary (8) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ option_num = binary (p_cur_byte); p_cur_byte = substr (OUR_NOP, 2); /* overwrite this option number */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Processing option ^d.", PROG, option_num); if ltp -> lt.telnet_state.last_was_WILL then do; ltp -> lt.telnet_state.last_was_WILL = "0"b; call option_invoked (option_num, READ); return; end; if ltp -> lt.telnet_state.last_was_DO then do; ltp -> lt.telnet_state.last_was_DO = "0"b; call option_invoked (option_num, WRITE); return; end; if ltp -> lt.telnet_state.last_was_WONT then do; ltp -> lt.telnet_state.last_was_WONT = "0"b; call option_revoked (option_num, READ); return; end; if ltp -> lt.telnet_state.last_was_DONT then do; ltp -> lt.telnet_state.last_was_DONT = "0"b; call option_revoked (option_num, WRITE); return; end; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: internal inconsistency in TELNET option negotiation.", PROG); return; /* this is actually an error condition */ end; /* end option_negotiation */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end net_tty_telnet_ */ end;  net_tty_xtach_.pl1 07/24/78 1453.9rew 07/24/78 1207.9 505386 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_tty_xtach_: procedure (); /* This module provides the attachment and control functions of */ /* the Network Answering Service pseudo-TTY support. This module is */ /* directly responsible for interpreting the state of the pseudo-TTY as */ /* derived from the states of the underlying Network connections and */ /* the state changing entry points in this module. Also, when logger_ */ /* receives an ICP request, it calls an entry point in this module to */ /* choose an appropriate pseudo-TTY. */ /* Initially coded by T. Skinner, March 16, 1971. */ /* Almost entirely rewritten by D. M. Wells, October 1975 to get around */ /* problems caused by new AS interface to pseudo-TTYs. */ /* Modified by D. M. Wells, August, 1976, to add xmog order calls */ /* Modified by D. M. Wells, October, 1976 to use new ring1 interfaces */ /* and to eliminate a looping problem when activating sockets. */ /* Modified by D. M. Wells, April, 1977, to remove transmogrifier. */ /* Modified by D. M. Wells, July, 1977 to add new orders for TTT. */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (P_dflag fixed binary (17), P_state fixed binary (4), P_foreign_host fixed binary (16), P_ptty_indx fixed binary (17), /* index of channel in network logger table */ P_log_indx fixed binary (17), P_assigned_sock_grp fixed binary (24), P_foreign_socket fixed binary (32), P_error_code fixed binary (35), P_dialup_event_chan fixed binary (71), P_user_process_id bit (36) aligned, P_ptty_name character (6), /* name of pseudo channel, e.g., net001 or ftp001 */ P_request character (*), (P_new_modes, P_old_modes) character (*), P_ev_msg_ptr pointer, P_wksp_ptr pointer, P_log_tbl_ptr pointer, P_as_entry_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (pin_indx fixed binary (1), (rd_state, wr_state) fixed binary (6), indx fixed binary (17), service_type fixed binary (17), channel_sock_grp fixed binary (24), frgn_sock fixed binary (32), ierr_code fixed binary (35), explanation character (8), access_ename character (32), access_dir character (168), term_modes character (256), (cs_ptr, ltp) pointer) automatic; declare 1 ttd aligned automatic like terminal_type_data; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ declare (netup fixed binary (17) initial (0), sig_counter fixed binary (17) initial (0), logp pointer initial (null ())) internal static; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare (terminal_info_version_1 fixed binary (17) initial (1), ttd_version_1 fixed binary (17) initial (1)) internal static options (constant); declare (user_pin_num (0 : 1) fixed binary (8) initial (0, 1), ftp_pin_num (0 : 1) fixed binary (8) initial (2, 3), PROG character (32) varying initial ("net_tty_xtach_")) internal static options (constant); /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare (based_fb35 fixed binary (35), based_char4 character (4)) based; declare 1 ev_msg aligned based, 2 common like event_message_template.common, 2 data_ptr pointer; declare 1 info_struc aligned based, 2 term_id character (4) unaligned, 2 flags, 3 baud_rate fixed binary (17) unaligned, 3 line_type fixed binary (17) unaligned, 3 pad bit (36) unaligned, 2 terminal_type fixed binary (17); /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare (net_as_$default_term_type fixed binary (17), net_as_$device_message fixed binary (71), net_as_$testing bit (1) aligned, net_as_$tracing bit (36) aligned, net_as_$trace_iocb pointer) external static; declare (error_table_$action_not_performed, error_table_$bad_index, error_table_$device_limit_exceeded, error_table_$device_not_usable, error_table_$imp_down, error_table_$invalid_device, error_table_$namedup, error_table_$net_not_up, error_table_$resource_unavailable, error_table_$segnamedup, error_table_$undefined_order_request, error_table_$unimplemented_version) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare clock_ constant entry () returns (fixed bin (71)), condition_ constant entry (char (*), entry), convert_binary_integer_$decimal_string constant entry (fixed bin (35)) returns (char (12) varying), cv_dec_check_ constant entry (char (*), fixed bin (35)) returns (fixed bin (35)), get_process_id_ constant entry () returns (bit (36) aligned), hcs_$chname_file constant entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$wakeup constant entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)), host_id_$abbrev constant entry (fixed bin (16), char (*), fixed bin (35)), ioa_$ioa_switch 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), ptr, fixed bin (17), fixed bin (35)), logger_$logger_init constant entry (fixed bin (35)), ncp_$attach_priv_socket constant entry (fixed bin (24), fixed bin (8), fixed bin (71), bit (36), fixed bin (35)), ncp_$clear_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$close_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$detach_socket constant entry (bit (36), fixed bin (35)), ncp_$disable_interrupts constant entry (bit (36), fixed bin (35)), ncp_$discard_buffered_data constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$get_socket_state constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$initiate_connection constant entry (bit (36), fixed bin (16), fixed bin (32), fixed bin (6), fixed bin (35)), ncp_$passoff_socket constant entry (bit (36), bit (36) aligned, bit (*), fixed bin (35)), ncp_$set_bytesize constant entry (bit (36), fixed bin (8), fixed bin (35)), net_log_ constant entry options (variable), net_log_$net_error_log constant entry options (variable), net_ring1_user_$get_access_dir constant entry (char (*), fixed bin (35)), net_tty_modes_$change_modes constant entry (ptr, char (*), char (*), fixed bin (35)), net_tty_modes_$get_modes_from_NCP constant entry (ptr, fixed bin (35)), net_tty_modes_$set_modes_in_NCP constant entry (ptr, fixed bin (35)), net_tty_telnet_$issue_AO constant entry (ptr, fixed bin (35)), net_tty_telnet_$propose_initial_options constant entry (ptr, fixed bin (35)), net_tty_telnet_$revoke_unsupported_options constant entry (ptr, fixed bin (35)), timer_manager_$alarm_wakeup constant entry (fixed bin (71), bit (2), fixed bin (71)), timer_manager_$reset_alarm_wakeup constant entry (fixed bin (71)), ttt_info_$modes constant entry (char (*), char (256), fixed bin (35)), ttt_info_$terminal_data constant entry (char (*), fixed bin (17), fixed bin (17), ptr, fixed bin (35)); declare (addr, dimension, hbound, lbound, mod, null, string, substr, unspec) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include line_types; % include log_tbl; % include net_as_states; % include net_event_template; % include set_term_type_info; % include terminal_info; % include terminal_type_data; % include tty_types; % include ttyp; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ net_tty_xtach_init: entry (P_log_tbl_ptr, P_error_code); P_error_code = 0; logp = P_log_tbl_ptr; return; /* * * * * * * * * * * * * * * * * * * * * * * */ net_index: entry (P_ptty_name, P_ptty_indx, P_state, P_as_entry_ptr, P_error_code); P_error_code = 0; P_state = 0; P_ptty_indx = 0; if logp = null () then do; call logger_$logger_init (P_error_code); if P_error_code ^= 0 then do; call net_log_$net_error_log (2, P_error_code, PROG, "Logger not successfully initialized."); return; end; end; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Attaching ^a", PROG, P_ptty_name); channel_sock_grp = cv_dec_check_ (substr (P_ptty_name, 4, 3), ierr_code); if ierr_code ^= 0 then do; P_error_code = error_table_$invalid_device; return; end; if (channel_sock_grp <= 0) | (channel_sock_grp >= 512) then do; /* NCP only reserves these group's as privileged */ P_error_code = error_table_$invalid_device; return; end; do indx = 1 to logp -> ltbl.max_inuse; ltp = addr (logp -> ltbl.entry (indx)); /* get pointer to entry */ if (ltp -> lt.active ^= PTTY_detached) & (channel_sock_grp = ltp -> lt.net_socket_group) then do; if ltp -> lt.tty_name ^= P_ptty_name then do; /* this group is assigned to another service */ P_error_code = error_table_$invalid_device; return; end; P_state = ltp -> lt.tty_state; P_ptty_indx = ltp -> lt.tty_index; return; end; end; do indx = 1 by 1 to logp -> ltbl.max_length while (logp -> ltbl.entry (indx).active ^= PTTY_detached); end; if indx > logp -> ltbl.max_length then do; P_error_code = error_table_$device_limit_exceeded; return; end; ltp = addr (logp -> ltbl.entry (indx)); ltp -> lt.tty_index = indx; ltp -> lt.active = PTTY_attached; P_ptty_indx = ltp -> lt.tty_index; if P_ptty_indx > logp -> ltbl.max_inuse then logp -> ltbl.max_inuse = P_ptty_indx; ltp -> lt.tty_name = P_ptty_name; /* fill in some info about this channel */ ltp -> lt.net_socket_group = channel_sock_grp; ltp -> lt.ansp = P_as_entry_ptr; ltp -> lt.assigned_service_type = SERVICE_login; /* default service type is for normal logins */ ltp -> lt.cur_service_type = ltp -> lt.assigned_service_type; call set_ptty_state (TTY_HUNGUP); call set_connection_state (LINE_CLOSED, "0"b, "attach"); ltp -> lt.sock_handle (READ), ltp -> lt.sock_handle (WRITE) = ""b; ltp -> lt.as_event_chn = 0; call initialize_line_variables (); ltp -> lt.sig_sw = ""b; /* reset "signal sent" switch */ call ipc_$create_ev_chn (ltp -> lt.ncp_event_chn, P_error_code); if P_error_code = 0 then call ipc_$decl_ev_call_chn (ltp -> lt.ncp_event_chn, net_wakeup, ltp, 1, P_error_code); if P_error_code ^= 0 then do; ltp -> lt.active = PTTY_detached; return; end; P_state = ltp -> lt.tty_state; access_ename = "socket_group." || convert_binary_integer_$decimal_string ((channel_sock_grp)) || ".acs"; call net_ring1_user_$get_access_dir (access_dir, (0)); call hcs_$chname_file (access_dir, "AS_logger", "", access_ename, P_error_code); if (P_error_code ^= 0) & (P_error_code ^= error_table_$segnamedup) & (P_error_code ^= error_table_$namedup) then return; P_error_code = 0; return; /* * * * * * * * * * * * * * * * * * * * * * * */ net_event: entry (P_ptty_indx, P_dialup_event_chan, P_state, P_error_code); ltp = find_psuedo_tty (P_ptty_indx, "event", P_state, P_error_code); if ltp -> lt.active ^= PTTY_attached then do; /* this entry is not assigned to anyone */ P_error_code = error_table_$device_not_usable; return; end; ltp -> lt.as_event_chn = P_dialup_event_chan; if ltp -> lt.line_state = LINE_UP_CONTROL /* if user currently in control of line */ then do; /* we should passoff the channel to ourselves */ call net_tty_modes_$get_modes_from_NCP (ltp, (0)); call net_tty_telnet_$revoke_unsupported_options (ltp, (0)); call set_connection_state (LINE_AS_CONTROL, "0"b, "AS-grab"); if ltp -> lt.rcte_in_effect then call net_tty_telnet_$issue_AO (ltp, (0)); /* in case user had outstanding RCTE SB */ end; call reactivate_sockets (ierr_code); if ierr_code ^= 0 then do; if ^ check_socket_error (ierr_code, "event_activation", "event") then call net_report_down ((0)); else do; ltp -> lt.active = PTTY_broken; call clear_connection ("activation-error", "1"b, P_state); P_error_code = ierr_code; return; end; end; ltp -> lt.need_Go_Ahead = "1"b; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_state: entry (P_ptty_indx, P_state, P_error_code); ltp = find_psuedo_tty (P_ptty_indx, "state", P_state, P_error_code); if ltp -> lt.active ^= PTTY_attached then do; call clear_connection ("state-error", "1"b, P_state); P_error_code = error_table_$device_not_usable; return; end; if (ltp -> lt.tty_state = TTY_HUNGUP) | (ltp -> lt.tty_state = TTY_LISTENING) then return; /* In these states, net states don't matter */ call get_socket_states (rd_state, wr_state); if (rd_state = 6) & (wr_state = 6) then return; /* Network connections are still open, everything ok */ call clear_connection ("socket-closed", "1"b, P_state); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_order: entry (P_ptty_indx, P_request, P_wksp_ptr, P_state, P_error_code); ltp = find_psuedo_tty (P_ptty_indx, "order " || P_request, P_state, P_error_code); if ltp -> lt.active ^= PTTY_attached then do; P_error_code = error_table_$device_not_usable; return; end; if P_request = "listen" /* This should be the only way that a pseudo-TTY */ then do; /* ever goes into "LISTENING" state. */ ltp -> lt.num_listens = ltp -> lt.num_listens + 1; if ltp -> lt.tty_state = TTY_HUNGUP then call set_ptty_state (TTY_LISTENING); P_state = ltp -> lt.tty_state; return; end; if P_request = "terminal_info" then do; if P_wksp_ptr -> terminal_info.version ^= terminal_info_version_1 then do; P_error_code = error_table_$unimplemented_version; return; end; P_wksp_ptr -> terminal_info.id = ltp -> lt.answerback; P_wksp_ptr -> terminal_info.term_type = ltp -> lt.terminal_type_name; P_wksp_ptr -> terminal_info.line_type = LINE_TELNET; P_wksp_ptr -> terminal_info.baud_rate = 0; unspec (P_wksp_ptr -> terminal_info.reserved) = ""b; return; end; if P_request = "info" then do; P_wksp_ptr -> info_struc.term_id = ltp -> lt.answerback; P_wksp_ptr -> info_struc.baud_rate = 0; P_wksp_ptr -> info_struc.line_type = LINE_TELNET; P_wksp_ptr -> info_struc.pad = ""b; P_wksp_ptr -> info_struc.terminal_type = ltp -> lt.old_terminal_type; return; end; if P_request = "hangup" then do; ltp -> lt.num_hangup_orders = ltp -> lt.num_hangup_orders + 1; call clear_connection ("order-hangup", "0"b, P_state); return; end; if P_request = "printer_off" then do; if (ltp -> lt.rcte_in_effect) | (ltp -> lt.printer_off_capability_asserted) then do; ltp -> lt.rcte_info.printer_on = "0"b; return; end; P_error_code = error_table_$action_not_performed; return; end; if P_request = "printer_on" then do; ltp -> lt.rcte_info.printer_on = "1"b; return; end; if P_request = "set_line_type" then do; if P_wksp_ptr -> based_fb35 ^= LINE_TELNET then P_error_code = error_table_$action_not_performed; return; end; if P_request = "set_term_type" then do; if P_wksp_ptr -> set_term_type_info.version ^= stti_version_1 then do; P_error_code = error_table_$unimplemented_version; return; end; ttd.version = ttd_version_1; if P_wksp_ptr -> set_term_type_info.ignore_line_type then call ttt_info_$terminal_data (P_wksp_ptr -> set_term_type_info.name, 0, 0, addr (ttd), P_error_code); else call ttt_info_$terminal_data (P_wksp_ptr -> set_term_type_info.name, LINE_TELNET, 0, addr (ttd), P_error_code); if P_error_code ^= 0 then return; if P_wksp_ptr -> set_term_type_info.send_initial_string then do; P_error_code = error_table_$action_not_performed; return; end; if P_wksp_ptr -> set_term_type_info.set_modes then do; call ttt_info_$modes (P_wksp_ptr -> set_term_type_info.name, term_modes, P_error_code); if P_error_code ^= 0 then return; call net_tty_modes_$change_modes (ltp, term_modes, (""), P_error_code); if P_error_code ^= 0 then return; end; ltp -> lt.terminal_type_name = P_wksp_ptr -> set_term_type_info.name; ltp -> lt.old_terminal_type = ttd.old_type; if ltp -> lt.old_terminal_type = TYPE_TTY33 then ltp -> lt.half = "1"b; else ltp -> lt.half = "0"b; return; end; if P_request = "set_type" | P_request = "set_terminal_type" then do; ltp -> lt.old_terminal_type = P_wksp_ptr -> based_fb35; ltp -> lt.terminal_type_name = tty_dev_type (ltp -> lt.old_terminal_type); if ltp -> lt.old_terminal_type = TYPE_TTY33 then ltp -> lt.half = "1"b; else ltp -> lt.half = "0"b; return; end; if P_request = "store_id" then do; ltp -> lt.answerback = P_wksp_ptr -> based_char4; return; end; if P_request = "set_service_type" then do; service_type = P_wksp_ptr -> based_fb35; if (service_type < lbound (SERVICE_type, 1)) | (service_type > hbound (SERVICE_type, 1)) then do; P_error_code = error_table_$action_not_performed; return; end; ltp -> lt.assigned_service_type = service_type; return; end; if P_request = "accept_printer_off" then do; ltp -> lt.printer_off_capability_asserted = "1"b; return; end; if P_request = "refuse_printer_off" then do; ltp -> lt.printer_off_capability_asserted = "0"b; return; end; P_error_code = error_table_$undefined_order_request; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_detach: entry (P_ptty_indx, P_dflag, P_state, P_error_code); ltp = find_psuedo_tty (P_ptty_indx, "detach", P_state, P_error_code); call clear_connection ("detach-hangup", "0"b, P_state); /* clear out NCP sockets if hooked up */ do pin_indx = READ, WRITE; call ncp_$detach_socket (ltp -> lt.sock_handle (pin_indx), (0)); ltp -> lt.sock_handle (pin_indx) = ""b; end; ltp -> lt.active = PTTY_detached; P_state = 0; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_detach_new_proc: entry (P_ptty_indx, P_user_process_id, P_state, P_error_code); ltp = find_psuedo_tty (P_ptty_indx, "detach_new_proc", P_state, P_error_code); string (ltp -> lt.buf) = ""; ltp -> lt.bufidx = 0; call net_tty_modes_$set_modes_in_NCP (ltp, P_error_code); ltp -> lt.passed_off_process_id = P_user_process_id; do pin_indx = READ, WRITE; call ncp_$passoff_socket (ltp -> lt.sock_handle (pin_indx), ltp -> lt.passed_off_process_id, ""b, ierr_code); if ierr_code ^= 0 then do; P_error_code = reflect_socket_error (ierr_code, "passoff", P_state); return; end; end; if ltp -> lt.assigned_service_type = SERVICE_ftp then do pin_indx = READ, WRITE; call ncp_$attach_priv_socket (ltp -> lt.net_socket_group, ftp_pin_num (pin_indx), 0, ltp -> lt.ftp_sock_handle (pin_indx), ierr_code); if ierr_code ^= 0 then do; P_error_code = reflect_socket_error (ierr_code, "ftp activate", P_state); return; end; call ncp_$passoff_socket (ltp -> lt.ftp_sock_handle (pin_indx), ltp -> lt.passed_off_process_id, ""b, ierr_code); if ierr_code ^= 0 then do; P_error_code = reflect_socket_error (ierr_code, "ftp passoff", P_state); return; end; end; call set_connection_state (LINE_UP_CONTROL, "0"b, "passoff"); /* now controlled by user */ return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_changemode: entry (P_ptty_indx, P_new_modes, P_old_modes, P_error_code); ltp = find_psuedo_tty (P_ptty_indx, "changemode " || P_new_modes, (0), P_error_code); call net_tty_modes_$change_modes (ltp, P_new_modes, P_old_modes, P_error_code); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ hunt_free_pseudo_tty: entry (P_log_indx, P_foreign_host, P_foreign_socket, P_assigned_sock_grp, P_error_code); P_error_code = 0; cs_ptr = addr (logp -> ltbl.contact_socket (P_log_indx)); do cs_ptr -> cs.tty_idx = 1 to logp -> ltbl.max_inuse; ltp = addr (logp -> ltbl.entry (cs_ptr -> cs.tty_idx)); if check_pseudo_tty () then goto accepted; end; call net_log_ (1, "^a: No sockets available for assignment to service ^a.", PROG, SERVICE_type (cs_ptr -> cs.service_type)); P_error_code = error_table_$resource_unavailable; return; accepted: P_assigned_sock_grp = ltp -> lt.net_socket_group; ltp -> lt.foreign_socket.host_num = P_foreign_host; ltp -> lt.foreign_socket.socket_num = P_foreign_socket + 2; ltp -> lt.cur_service_type = cs_ptr -> cs.service_type; call set_connection_state (LINE_OPENING, "1"b, "acpt-ICP"); ltp -> lt.num_connections = ltp -> lt.num_connections + 1; do pin_indx = READ, WRITE; if pin_indx = READ then frgn_sock = ltp -> lt.foreign_socket.socket_num + 1; else frgn_sock = ltp -> lt.foreign_socket.socket_num + 0; call ncp_$set_bytesize (ltp -> lt.sock_handle (pin_indx), 8, ierr_code); if ierr_code ^= 0 then do; if ^ check_socket_error (ierr_code, "setbytesize8", cs_ptr -> cs.log_type) then; P_error_code = ierr_code; return; end; call ncp_$initiate_connection (ltp -> lt.sock_handle (pin_indx), P_foreign_host, frgn_sock, (0), ierr_code); if ierr_code ^= 0 then do; if ^ check_socket_error (ierr_code, "initiate-connection", cs_ptr -> cs.log_type) then; P_error_code = ierr_code; return; end; end; call set_ptty_state (TTY_EXPERIMENTING); /* We are now trying to get connections open */ ltp -> lt.contact_pin = cs_ptr -> cs.log_pin; ltp -> lt.service_index = cs_ptr -> cs.service_index; ltp -> lt.service_name = cs_ptr -> cs.log_type; call initialize_line_variables (); if (ltp -> lt.contact_pin = 1) | (ltp -> lt.contact_pin = 3) then ltp -> lt.using_new_TELNET = "0"b; else ltp -> lt.using_new_TELNET = "1"b; call host_id_$abbrev (ltp -> lt.foreign_socket.host_num, ltp -> lt.hostname, ierr_code); if ierr_code ^= 0 then ltp -> lt.hostname = "NET "; ltp -> lt.answerback = ltp -> lt.hostname; return; net_down: P_error_code = error_table_$net_not_up; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ net_wakeup: entry (P_ev_msg_ptr); ltp = P_ev_msg_ptr -> ev_msg.data_ptr; if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: net tty wakeup: ltp = ^p, message = ^24.3b", PROG, ltp, P_ev_msg_ptr -> ev_msg.message); /* We probably should check the pointer ltp for obvious problems */ if (sig_counter < 200) & (net_as_$testing ^= "1"b) then call condition_ ("any_other", sig_handler); if (ltp -> lt.line_state < lbound (tty_dispatch, 1)) | (ltp -> lt.line_state > hbound (tty_dispatch, 1)) then do; call net_log_$net_error_log (0, 0, PROG, "Improper state ^d for dispatch state.", ltp -> lt.line_state); ltp -> lt.line_state = 0; return; end; ltp -> lt.num_wakeups_to_net_as = ltp -> lt.num_wakeups_to_net_as + 1; goto tty_dispatch (ltp -> lt.line_state); /* * * * * * * * * * * * * * * * * * */ tty_dispatch (0): /* LINE_CLOSED -- */ goto call_finish; /* * * * * * * * * * * * * * * * * * * */ tty_dispatch (1): /* LINE_OPENING -- */ call get_socket_states (rd_state, wr_state); if ((rd_state ^= 6) & (rd_state ^= 5)) | ((wr_state ^= 6) & (wr_state ^= 5)) then do; call clear_connection ("open-not-complete", "1"b, (0)); goto call_finish; end; if (rd_state = 5) | (wr_state = 5) then do; if ltp -> lt.state_change_timeout > clock_ () then goto call_finish; /* no timeout yet, go away for now */ call clear_connection ("RFC-sent-timeout", "1"b, (0)); goto call_finish; end; ltp -> lt.last_dialup_time = clock_ (); call set_connection_state (LINE_AS_CONTROL, "0"b, "connopen"); call set_ptty_state (TTY_DIALED); call net_tty_telnet_$propose_initial_options (ltp, ierr_code); if ierr_code ^= 0 then do; call clear_connection ("initial-options", "1"b, (0)); goto call_finish; end; call signal_overseer (); goto call_finish; /* * * * * * * * * * * * * * * * * * * */ tty_dispatch (2): /* LINE_AS_CONTROL -- Answering Service is reading from terminal */ call signal_overseer (); goto call_finish; /* * * * * * * * * * * * * * * * * * * */ tty_dispatch (3): /* LINE_UP_CONTROL -- User process is using terminal */ call get_socket_states (rd_state, wr_state); if (rd_state ^= 6) | (wr_state ^= 6) then do; call clear_connection ("UP-control-hangup", "1"b, (0)); goto call_finish; end; goto call_finish; /* ignore network events */ /* * * * * * * * * * * * * * * * * * * */ tty_dispatch (4): /* LINE_CLOSING -- we have requested close, see if done */ call get_socket_states (rd_state, wr_state); if (rd_state ^= 1) | (wr_state ^= 1) then do; if ltp -> lt.state_change_timeout > clock_ () then return; /* no timeout yet, go away for now */ call force_deactivate_ptty (); end; call set_connection_state (LINE_CLOSED, "0"b, "connclsd"); call signal_overseer (); goto call_finish; /* * * * * * * * * * * * * * * * * * * * * * * * */ call_finish: if sig_counter > 0 then sig_counter = sig_counter - 1; /* decrement threshold for successful finish */ return; /* * * * * * * * * * * * * * * * * * * * * * * * */ close_pseudo_tty: entry (P_ptty_indx, P_error_code); /* This entry provides logger_ a means to close user sockets which have timed out without being accepted */ P_error_code = 0; ltp = addr (logp -> ltbl.entry (P_ptty_indx)); call clear_connection ("close_pseudo_tty", "1"b, (0)); return; /* * * * * * * * * * * * * * * * * * * * * * * */ report_unclaimed_signal: ierr_code = 0; sig_counter = sig_counter + 10; /* increment ignoral threshold */ if sig_counter > 90 then explanation = "MANYSIGS"; else explanation = "U_SIGNAL"; if sig_counter < 100 then call net_log_$net_error_log (0, ierr_code, PROG, "Error '^a' for ^a from ^a", explanation, ltp -> lt.tty_name, ltp -> lt.hostname); return; /* * * * * * * * * * * * * * * * * * * * * * */ net_report_down: entry (P_error_code); /* This entry is for other modules of the Network Logger to report the discovery that the Network Control Program is not operating */ P_error_code = 0; if netup < 1 then return; netup = -1; /* don't do again for downed network */ do indx = 1 to logp -> ltbl.max_inuse; /* simulate a hangup for each logged-in channel */ ltp = addr (logp -> ltbl.entry (indx)); if (ltp -> lt.active ^= PTTY_detached) then do; ltp -> lt.active = PTTY_attached; /* give any broken channels a fresh start in life */ /* in case the AS hasn't noticed they are broken */ call clear_connection ("net-report-down", "1"b, (0)); /* should detach these socket to be sure */ ltp -> lt.sock_handle (READ) = ""b; ltp -> lt.sock_handle (WRITE) = ""b; ltp -> lt.ftp_sock_handle (READ) = ""b; ltp -> lt.ftp_sock_handle (WRITE) = ""b; end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * */ find_psuedo_tty: procedure (p_tty_indx, p_function, p_state, p_err_code) returns (ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_state fixed binary (4), p_tty_indx fixed binary (17), p_err_code fixed binary (35), p_function character (*)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare tty_indx fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Entering, ^a for ^d", PROG, p_function, p_tty_indx); p_err_code = 0; p_state = 0; tty_indx = p_tty_indx; if (tty_indx <= 0) | (tty_indx > logp -> ltbl.max_inuse) then do; p_err_code = error_table_$bad_index; goto call_finish; end; if logp -> ltbl.entry (tty_indx).active = PTTY_detached then do; p_err_code = error_table_$bad_index; goto call_finish; end; p_state = logp -> ltbl.entry (tty_indx).tty_state; return (addr (logp -> ltbl.entry (tty_indx))); end; /* end find_psuedo_tty */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_pseudo_tty: procedure () returns (bit (1)); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (pin_indx fixed binary (2), state fixed binary (6)) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if ltp -> lt.active ^= PTTY_attached then return ("0"b); /* this pseudo_tty is not attached or broken */ if ltp -> lt.tty_state ^= TTY_LISTENING then return ("0"b); /* this ptty is not listening for dialups */ if ltp -> lt.line_state ^= LINE_CLOSED then return ("0"b); /* this ptty is doing something else, ignore for now */ if ltp -> lt.assigned_service_type ^= cs_ptr -> cs.service_type then return ("0"b); if (ltp -> lt.sock_handle (READ) = ""b) | (ltp -> lt.sock_handle (WRITE) = ""b) then do; call reactivate_sockets (ierr_code); call initialize_line_variables (); if ierr_code ^= 0 then do; if ^ check_socket_error (ierr_code, "activate", cs_ptr -> cs.log_type) then goto net_down; return ("0"b); end; end; do pin_indx = READ, WRITE; call ncp_$get_socket_state (ltp -> lt.sock_handle (pin_indx), state, ierr_code); if ierr_code ^= 0 then do; if ^ check_socket_error (ierr_code, "chnstate", cs_ptr -> cs.log_type) then goto net_down; return ("0"b); end; if state ^= 1 then return ("0"b); /* this socket isn't in right state -- bad */ end; return ("1"b); end; /* end check_pseudo_tty */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_socket_error: procedure (p_code, explanation, type_name) returns (bit (1)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_code fixed binary (35), (explanation, type_name) character (*)) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (p_code = error_table_$net_not_up) | (p_code = error_table_$imp_down) then return ("0"b); call force_deactivate_ptty (); call clear_connection ("socket-error-clear", "1"b, (0)); call net_log_$net_error_log (0, p_code, PROG, "ttychan ^a error ""^a"" by ^a", type_name, explanation, ltp -> lt.tty_name); return ("1"b); end; /* end check_socket_error */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ force_deactivate_ptty: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare pin_idx fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Force-deactivating ^p", PROG, ltp); ltp -> lt.num_force_clears = ltp -> lt.num_force_clears + 1; call set_connection_state (LINE_CLOSED, "0"b, "forcdeac"); do pin_idx = READ, WRITE; call ncp_$clear_connection (ltp -> lt.sock_handle (pin_idx), (0), (0)); call ncp_$detach_socket (ltp -> lt.sock_handle (pin_idx), (0)); ltp -> lt.sock_handle (pin_idx) = ""b; if ltp -> lt.ftp_sock_handle (pin_idx) ^= ""b then do; call ncp_$clear_connection (ltp -> lt.sock_handle (pin_idx), (0), (0)); call ncp_$detach_socket (ltp -> lt.ftp_sock_handle (pin_indx), (0)); ltp -> lt.ftp_sock_handle (pin_idx) = ""b; end; end; return; end; /* end force_deactivate_ptty */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_socket_states: procedure (p_rd_state, p_wr_state); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_rd_state, p_wr_state) fixed binary (6) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (state (0 : 1) fixed binary (6), err_code fixed binary (35), ncp_pin fixed binary (1)) automatic; /* * * * * * * * * * * * * * * * * * * * * * */ do ncp_pin = READ, WRITE; call ncp_$get_socket_state (ltp -> lt.sock_handle (ncp_pin), state (ncp_pin), err_code); if err_code ^= 0 then state (ncp_pin) = -1; end; p_rd_state = state (READ); p_wr_state = state (WRITE); return; end; /* end get_socket_states */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ signal_overseer: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: signal overseer: logger tvec = ^d", PROG, ltp -> lt.line_state); call hcs_$wakeup (get_process_id_ (), ltp -> lt.as_event_chn, net_as_$device_message, (0)); ltp -> lt.num_wakeups_to_as = ltp -> lt.num_wakeups_to_as + 1; return; end; /* end signal_overseer */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_ptty_state: procedure (p_new_state); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_new_state fixed binary (4) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ /* trace into history array */ ltp -> lt.tty_state = p_new_state; return; end; /* end set_ptty_state */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ fill_history_slot: procedure (p_code, p_sock_state, p_comment); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_sock_state fixed binary (6), p_code fixed binary (35), p_comment character (8)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare slot fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ slot = mod (ltp -> lt.history.num_state_changes, dimension (ltp -> lt.history.state_block, 1)); ltp -> lt.history.state_block (slot).entry_time = clock_ (); ltp -> lt.history.state_block (slot).status_code = p_code; ltp -> lt.history.state_block (slot).netstate = 0; ltp -> lt.history.state_block (slot).socket_state = 0; ltp -> lt.history.state_block (slot).function = 0; ltp -> lt.history.state_block (slot).ptty_state = ltp -> lt.tty_state; ltp -> lt.history.state_block (slot).comment = p_comment; ltp -> lt.history.num_state_changes = ltp -> lt.history.num_state_changes + 1; return; end; /* end fill_history_slot */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_connection_state: procedure (p_new_state, p_set_timeout, p_comment); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_new_state fixed binary (3), p_set_timeout bit (1), p_comment character (8)) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: pseudo_tty socket ^p set to state ^d.", PROG, ltp, p_new_state); ltp -> lt.line_state = p_new_state; call timer_manager_$reset_alarm_wakeup (ltp -> lt.ncp_event_chn); ltp -> lt.state_change_timeout = 0; if p_set_timeout then do; ltp -> lt.state_change_timeout = clock_ () + logp -> ltbl.ptty_grace_period; call timer_manager_$alarm_wakeup (ltp -> lt.state_change_timeout, "00"b, ltp -> lt.ncp_event_chn); end; call fill_history_slot (0, 0, p_comment); return; end; /* end set_connection_state */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ clear_connection: procedure (p_reason, p_flush_output, p_state); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_state fixed binary (4), p_flush_output bit (1), p_reason character (*)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ((r_state, w_state) fixed binary (6), err_code fixed binary (35), this_dialup_period fixed binary (71)) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: clearing connection ^p because ^a", PROG, ltp, p_reason); if p_flush_output then call ncp_$discard_buffered_data (ltp -> lt.sock_handle (WRITE), (0), (0)); call ncp_$close_connection (ltp -> lt.sock_handle (WRITE), (0), (0)); call ncp_$close_connection (ltp -> lt.sock_handle (READ), (0), (0)); call ncp_$discard_buffered_data (ltp -> lt.sock_handle (READ), (0), (0)); call ncp_$get_socket_state (ltp -> lt.sock_handle (READ), r_state, err_code); if err_code ^= 0 then do; ltp -> lt.sock_handle (READ) = ""b; r_state = 1; end; call ncp_$get_socket_state (ltp -> lt.sock_handle (WRITE), w_state, err_code); if err_code ^= 0 then do; ltp -> lt.sock_handle (WRITE) = ""b; w_state = 1; end; if ltp -> lt.tty_state = TTY_DIALED then do; this_dialup_period = clock_ () - ltp -> lt.last_dialup_time; ltp -> lt.cumulative_dialed_up_time = ltp -> lt.cumulative_dialed_up_time + this_dialup_period; end; call set_ptty_state (TTY_HUNGUP); call initialize_line_variables (); if (r_state = 1) & (w_state = 1) then call set_connection_state (LINE_CLOSED, "0"b, "conncler"); else call set_connection_state (LINE_CLOSING, "1"b, "conncler"); call signal_overseer (); p_state = ltp -> lt.tty_state; return; end; /* end clear_connection */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reactivate_sockets: procedure (p_err_code); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_err_code fixed binary (35) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare pin_indx fixed binary (2) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: Activating sockets for ^p", PROG, ltp); p_err_code = 0; do pin_indx = READ, WRITE; call ncp_$disable_interrupts (ltp -> lt.sock_handle (pin_indx), (0)); ltp -> lt.sock_handle (pin_indx) = ""b; if ltp -> lt.ftp_sock_handle (pin_indx) ^= ""b then call ncp_$detach_socket (ltp -> lt.ftp_sock_handle (pin_indx), (0)); ltp -> lt.ftp_sock_handle (pin_indx) = ""b; end; ltp -> lt.num_activations = ltp -> lt.num_activations + 1; do pin_indx = READ, WRITE; call ncp_$attach_priv_socket (ltp -> lt.net_socket_group, user_pin_num (pin_indx), ltp -> lt.ncp_event_chn, ltp -> lt.sock_handle (pin_indx), p_err_code); if p_err_code ^= 0 then return; netup = 1; /* The Network is up; reset in case netup was 0 */ end; ltp -> lt.sig_sw = ""b; /* reset "signal sent" switch */ return; end; /* end reactivate_sockets */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ initialize_line_variables: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ ltp -> lt.bufidx = 0; string (ltp -> lt.telnet_state) = ""b; string (ltp -> lt.option_in_effect (READ)) = ""b; string (ltp -> lt.option_in_effect (WRITE)) = ""b; string (ltp -> lt.option_in_negotiation (READ)) = ""b; string (ltp -> lt.option_in_negotiation (WRITE)) = ""b; ltp -> lt.need_Go_Ahead = "1"b; ltp -> lt.rcte_in_effect = "0"b; ltp -> lt.printer_on = "1"b; ltp -> lt.waiting_for_break_char = "0"b; ltp -> lt.cr_seen = ""b; ltp -> lt.escape_seen = ""b; ltp -> lt.hostname = ""; ltp -> lt.old_terminal_type = net_as_$default_term_type; /* get this from ALM data base */ ltp -> lt.terminal_type_name = tty_dev_type (ltp -> lt.old_terminal_type); string (ltp -> lt.special_control) = ""b; call net_tty_modes_$change_modes (ltp, "init", (""), (0)); return; end; /* end initialize_line_variables */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reflect_socket_error: procedure (p_code, p_explanation, p_state) returns (fixed bin (35)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_state fixed binary (4), p_code fixed binary (35), p_explanation character (*)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare explanation character (8) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ explanation = p_explanation; call set_ptty_state (TTY_HUNGUP); p_state = ltp -> lt.tty_state; sig_counter = sig_counter + 5; /* increment ignoral threshold because of socket error */ if sig_counter > 90 then explanation = "manyerrs"; if netup < 1 then return (0); /* don't report if closing out down network */ if sig_counter < 100 then call net_log_$net_error_log (0, p_code, PROG, "Error '^a' for ^a from ^a", explanation, ltp -> lt.tty_name, ltp -> lt.hostname); if (p_code = error_table_$net_not_up) | (p_code = error_table_$imp_down) then do; call net_report_down (p_code); return (0); end; if (sig_counter < 200) then do; call clear_connection ("reflect_socket_error", "1"b, (0)); return (p_code); end; return (p_code); end; /* end reflect_socket_error */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ sig_handler: procedure (mcp, cname, crawlp, infop, re_search); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ dcl (mcp, crawlp, infop) ptr, cname char (*), re_search bit (1) aligned; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare table_indx fixed binary (17) automatic; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare ok_conditions (1 : 5) character (32) initial ( "cput", "alrm", "quit", "mme2", "program_interrupt") internal static; /* * * * * * * * * * * * * * * * * * * * * * * * */ if net_as_$tracing ^= ""b then call ioa_$ioa_switch (net_as_$trace_iocb, "^a: unclaimed signal of ^a", PROG, cname); re_search = "1"b; do table_indx = lbound (ok_conditions, 1) by 1 to hbound (ok_conditions, 1); if cname = ok_conditions (table_indx) then return; /* return to signal_ and let continue up stack */ end; call net_log_$net_error_log (0, 0, PROG, "Network error ""^a"" signalled.", cname); explanation = ""; /* call as_$dump?? */ goto report_unclaimed_signal; end; /* end sig_handler */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* BEGIN MESSAGE DOCUMENTATION Message: net_tty_xtach_: ERROR-MESSAGE Logger not successfully initialized. S: net-as (severity2) T: $init M: The ARPANET Answering Service programs could not be initialized. No users will be able to login from the ARPANET. A: $contact_sa After the problem has been corrected, the system should be shut down and re-booted so that ARPANET users can login. Message: net_tty_xtach_: No sockets available for assignment to service SERVICE. S: net-as (severity1) T: $run M: When an ARPANET user requested a login, the system could not find a TTY channel to assign to him. This could be because not enough channels have been configured for ARPANET users, or because many ARPANET channels have been dropped by the Answering Service due to errors. A: $inform_sa If not enough channels have been configured for ARPANET users, the System Administrator should add more ARPANET channels to the CMF and then install a new CDT. If the SERVICE was TELNET, more "netxxx" channels should be added; if the service was FTP, more "ftpxxx" channels should be added. Message: net_tty_xtach_: ERROR-MESSAGE Improper state STATE-NUM for dispatch state. S: net-as (severity0) T: $run M: A bad value has been found in the internal state of the ARPANET portion of the Answering Service. This may be the result of a store error, a programming error, or a bad patch. The system attempts to recover and resume normal operation. A: $inform_sa Message: net_tty_xtach_: ERROR-MESSAGE Error 'EXPLANATION' for TTY-NAME from HOST S: net-as (severity0) T: $run M: While operating TTY channel TTY-NAME, which was connected to ARPANET host HOST, an error occurred. A: $ignore The TTY channel has been hungup and reinitialized. Message: net_tty_xtach_: ERROR-MESSAGE ttychan SERVICE error "EXPLANATION" by TTY-NAME S: net-as (severity0) T: $run M: While manipulating TTY channel TTY-NAME, the ARPANET portion of the Answering Service detected a problem. A: $ignore The TTY channel has been hungup and reinitialized. Message: net_tty_xtach_: Network error "CONDITION" signalled. S: net-as (severity0) T: $run M: While the ARPANET portion of the Answering Service was operating, the system condition CONDITION was signalled. A: $note The system attempts to recover and resume normal operation. END MESSAGE DOCUMENTATION */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end net_tty_xtach_ */  network_exec_.pl1 07/24/78 1453.9rew 07/24/78 1208.3 303624 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1974 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ network_exec_: procedure (); /* Login/quit responder for SysDaemon processes. Coded by M A Padlipsky, 4/70. Modified October 1971 by C Garman */ /* daemon_exec_ pirated and merged with net_driver to form network_exec_. Edwin Meyer, May 1973. */ /* auto_reinit on and off entry points added, and initialization code moved */ /* out of normal working set (at least in the source language) by dm wells Aug 1973. */ /* Fixed safety timer bugs, added initialization re-try and auto dump facility 9/3/73, Ken Pogran */ /* Added resetread call on entry to network_exec, improved auto dump facility, incorporated minimum time interval between re-initializations 11/73, Ken Pogran */ /* Added own default handler, to attempt to get some information before process terminations, 12/73, Ken Pogran */ /* Found and fixed process termination bug, 1/74, Ken Pogran */ /* Modified to automatically re-initialize on getting error_table_$net_not_up from NCP, 1/74, Ken Pogran */ /* Miscellaneous modifications, 3/74 by Ken Pogran */ /* Modified to call hcs_$get_process_usage, anticipate netp_ call to set hardcore gate ACLs, and avoid all-upper-case messages on the BOS console, 10/74, by Ken Pogran */ /* Modified to check for I/O status returned by NCP, 5/75, by Ken Pogran */ /* Modified to use new host table mechanism for initializing host communication */ /* Hacked for extended host addresses, B. Greenberg 3/29/78 */ /* by D. M. Wells, 10/75 */ dcl acl_count fixed binary (17) automatic; dcl acl_ptr pointer automatic; dcl auto_dump_desired bit (1) internal static initial ("0"b); dcl auto_reinit_count fixed bin static; /* if this number becomes > auto_reinit_threshold, the NCP will be crashed rather than automatically reinited */ dcl auto_reinit_threshold fixed bin static init (-1); /* set from defaul_auto_reinit_threshold if auto reiniting */ dcl based_token based (token_ptr) char (len); /* used in parsing strings */ dcl char_error char (4); /* denotes the call which produced an error */ dcl code fixed bin (35); /* a Multics standard error code */ dcl cur_time fixed bin (71) init (0); /* current clock_ time */ dcl default_auto_reinit_threshold fixed bin static initial (7); /* see comment for auto_reinit_threshold */ dcl entry_name char (32); /* used in append_link and invoke_exec_com */ dcl exec_sw bit (1) static init (""b); /* on when within NETWORK EXEC */ dcl fixed_how_long fixed bin; /* how long will the IMP be down? */ dcl fixed_how_soon fixed bin; /* how soon is the IMP going down? */ dcl fixed_why fixed bin; /* why is IMP going down? */ dcl grace_time fixed bin (71) init (0); /* time at which grace period is up */ dcl grace_time_increment fixed bin (71) initial (30000000); /* 30 sec max allowed in network_exec */ dcl hold_sw fixed bin static; /* if > 0, automatic returns from NETWORK_EXEC inhibited */ dcl home_dir char (168) static; dcl host_on_off fixed bin (1); /* 0 - to turn off (1); 1 - to turn on */ dcl hours fixed bin; /* for interpretting IMP messages */ dcl (i, j) fixed bin; /* temporaries */ dcl imp_state char (8) static init (""); /* current IMP state */ dcl last_time fixed bin (71) static init (0); /* last time the IMP state changed */ dcl (len, len1) fixed bin; /* used in parsing input request lines */ dcl linex char (168); /* input request line buffer */ dcl log_message char (120) var; /* to go into the network log */ dcl ncp_state_modified bit (1) static; /* on if NCP state changed while in NETWORK_EXEC */ dcl net_exec_auto_return label static; /* to unwind thru multiple invocations of NETWORK EXEC when returning */ dcl net_exec_grace_time fixed bin (71) init (0); /* time after which we auto return from NETWORK_EXEC */ dcl net_exec_return label static; /* return for NETWORK_EXEC */ dcl network_state fixed bin static init (0); /* current state of the NCP */ dcl req char (12); /* request name */ dcl testsw bit (1) static init (""b); /* on if invoked for testing */ dcl token_ptr ptr; /* used in parsing strings */ dcl wakeup_count fixed bin static; /* for metering the number of network wakeups */ dcl request_list (15) char (12) static init ("admin", "down", "dump", "hold", "host_list", "host_off", "host_on", "logout", "re_init", "start", "survey", "up", "new_proc", "comment", "reinit"); declare 1 process_usage aligned internal static, 2 number fixed bin initial (5), 2 total_cpu fixed bin (71), 2 memory_usage fixed bin (71), 2 page_faults fixed bin (35), 2 pre_pages fixed bin (35), 2 virtual_cpu fixed bin (71); declare 1 new_process_usage aligned like process_usage; dcl 1 global_queue aligned, /* See imp_queues.incl.pl1 */ 2 type fixed bin, 2 state char (8) aligned, 2 message bit (32) aligned, 2 imp_index fixed bin, 2 host fixed bin (32), 2 link fixed bin, 2 st aligned, 3 sba (0:17) bit (1) unaligned; dcl 1 wait_list aligned static, 2 no_of_channels fixed bin init (3), 2 channels (3) fixed bin (71); declare imp_reason (3) char (40) varying internal static initial ("scheduled preventive maintenance", "scheduled software reload", "emergency restart"); declare 1 status_structure aligned, 2 imp_state char (8), 2 time_imp_state_changed fixed bin (71), 2 imp_state_change_count fixed bin (35), 2 imp_special_message unaligned, 3 pad1 bit (4), 3 type bit (4), 3 pad2 bit (8), 3 why bit (2), 3 how_soon bit (4), 3 how_long bit (10), 2 time_ncp_state_changed fixed bin (71), 2 ncp_state fixed bin, 2 net_error_count fixed bin, 2 local_host_id fixed bin (32); dcl 1 message, 2 chname fixed bin (71), 2 mess fixed bin (71), 2 sender bit (36), 2 origin, 3 dev_signal bit (18), 3 ring bit (18), 2 channel_index fixed bin; dcl (addr, binary, divide, float, hbound, index, lbound, length, null, string, substr, unspec) builtin; dcl change_wdir_ entry (char (168) aligned, fixed bin (35)); dcl clock_ constant entry () returns (fixed bin (71)); dcl com_err_ constant entry options (variable); dcl (ioa_, ioa_$nnl) entry options (variable); dcl condition_ entry (char (*), entry); dcl convert_binary_integer_$decimal_string entry (fixed bin) returns (char (12) var); dcl dump_host_table_$get_attribute_string entry (fixed bin (32), bit (*), fixed bin (35)); dcl dump_host_table_$get_host_number entry (fixed bin, fixed bin (32), fixed bin (35)); dcl exec_com entry options (variable); dcl get_system_free_area_ constant entry () returns (ptr); dcl get_wdir_ entry returns (char (168) aligned); dcl hcs_$append_link entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$assign_channel ext entry (fixed bin (71), fixed bin (35)); dcl hcs_$get_process_usage ext entry (ptr, fixed bin (35)); dcl hcs_$list_acl constant entry (char (*), char (*), ptr, ptr, ptr, fixed bin (17), fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl interpret_absi_status_ constant entry (bit (*), bit (*), char (*) varying, fixed bin (35)); dcl host_id_$check_id ext entry (char (*), bit (1), fixed bin (32), bit (1), fixed bin (35)); dcl ipc_$delete_ev_chn ext entry (fixed bin (71), fixed bin (35)); /* also deletes spec ev chans */ dcl ios_$read_ptr external entry (ptr, fixed bin, fixed bin); dcl iox_$control constant entry (ptr, char (*), ptr, fixed bin (35)); dcl ipc_$block external entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn external entry (fixed bin (71), fixed bin (35)); dcl enter_admin_mode_ external entry; dcl logout external entry; dcl net_$ncp_network_status entry (fixed bin, ptr, fixed bin (35)); dcl ncp_$add_global_ev_chn entry (fixed bin (71), fixed bin (35)); dcl netp_$ncp_host_comm constant entry (fixed bin (1), fixed bin (32), fixed bin, fixed bin (35)); dcl netp_$ncp_init ext entry (fixed bin (71), fixed bin, fixed bin (35)); dcl netp_$replace_restrict_gate_acl entry (ptr, fixed bin, fixed bin (35)); dcl net_log_ ext entry options (variable); dcl net_log_$net_error_log ext entry options (variable); dcl netp_$ncp_daemon_wakeup entry (ptr, fixed bin (35)); dcl new_proc external entry; dcl reversion_ entry (char (*)); dcl standard_default_handler_ entry; dcl timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry); dcl user_info_$homedir entry (char (*)); dcl timer_manager_$alarm_interrupt entry; dcl timer_manager_$alarm_wakeup ext entry (fixed bin (71), bit (2), fixed bin (71)); dcl timer_manager_$cpu_time_interrupt entry; dcl timer_manager_$reset_alarm_call entry (entry); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl net_host_info_data_$communicate_attribute fixed binary (24) external static; dcl net_host_table_$max_host_number fixed bin external; dcl iox_$user_io pointer external static; dcl error_table_$net_not_up ext fixed binary (35); dcl error_table_$imp_down ext fixed binary (35); /* MAIN ENTRY - we get here right after process initialization */ if ^ testsw then do; /* if being run in real Network Daemon process */ call user_info_$homedir (home_dir); /* get home dir we are to use */ call change_wdir_ ((home_dir), code); /* and change to it */ if code ^= 0 then do; char_error = "swdr"; goto pi_error; end; end; else do; /* else we are being tested in a normal process */ home_dir = get_wdir_ (); /* so just note what dir we are in already */ end; call condition_ ("quit", network_exec); /* We'll handle quits ourselves, thanks */ call condition_ ("alrm", timer_manager_$alarm_interrupt); /* Setup for use of timer_manager_ */ call condition_ ("cput", timer_manager_$cpu_time_interrupt); /* ditto */ call condition_ ("any_other", network_exec_handler); call iox_$control (iox_$user_io, "quit_enable", null (), code); if code ^= 0 then do; char_error = "quit"; goto pi_error; end; /* will link to tools versions if they do not already exist */ do entry_name = "net_survey.ec", "net_dump.ec", "net_dump_subr.ec", "connect_access"; call append_link; end; call hcs_$status_minf (home_dir, "start_up.ec", 1, i /* entry type */, (0), code); if code = 0 then if i = 1 then do; /* there is a start_up.ec */ call invoke_exec_com ("start_up"); end; if auto_reinit_threshold = -1 /* if never set an automatic reinitialization */ then auto_reinit_threshold = default_auto_reinit_threshold; /* then set one from default */ auto_reinit_count = 0; net_exec_return = process_alarm; /* to find the place for NETWORK EXEC to return to */ net_exec_auto_return = return_from_network_exec; /* where to go on EXEC mode timeout */ reinit_ncp: /* all automatic re_inits enter here */ call ncp_init (code); /* to turn on the NCP */ if code ^= 0 then call network_exec; /* enter it manually */ call hcs_$get_process_usage (addr (process_usage), code); /* Start up metering */ wakeup_count = 0; /* Start from scratch on wakeups, too */ goto process_alarm; /* to set up the first alarm and begin normal service */ process_wakeup: /* This block implements normal network service. */ if testsw then call ioa_ ("Wakeup."); /* It is located ahead of process_alarm to keep it all */ /* in the same page. */ call netp_$ncp_daemon_wakeup (addr (global_queue), code); if code ^= 0 then if code < 0 then call interpret_IMP_status (code); else go to error; if global_queue.type ^= 0 then do; /* we've got something */ if global_queue.type = 3 then goto process_changed_imp_state; /* else the type is incomprehensible */ call net_log_ (1, "network_exec_: Bad queue entry type ^d returned by ncp_daemon_wakeup", global_queue.type); goto reinitialize; end; wakeup_count = wakeup_count + 1; if wakeup_count > 99 then do; wakeup_count = wakeup_count - 100; call hcs_$get_process_usage (addr (new_process_usage), code); call net_log_ (0, "network_exec_: (Meters) 100 wakeups, ^.3f vcpu, ^.3f mu, ^d pf", float (new_process_usage.virtual_cpu - process_usage.virtual_cpu) * 1e-6, float (new_process_usage.memory_usage - process_usage.memory_usage) * 1e-3, new_process_usage.page_faults - process_usage.page_faults); process_usage = new_process_usage; /* aggregate assignment! */ end; block: do while ("1"b); call ipc_$block (addr (wait_list), addr (message), code); if code ^= 0 then go to error; if message.channel_index = 1 then go to process_wakeup; /* network wakeup */ if message.channel_index = 2 then go to process_alarm; /* alarm wakeup */ if message.channel_index = 3 then goto process_imp_message; /* to process imp special message */ call net_log_ (1, "network_exec_: Bad wakeup occurred on index ^d", i); end; /* returns from NETWORK_EXEC in which the NCP state has changed enter here */ process_alarm: /* execute this code to check the reason for the alarm wakeup */ if testsw then call ioa_ ("Alarm wakeup."); cur_time = clock_ (); if grace_time > cur_time then goto process_wakeup; if auto_reinit_count ^=0 then auto_reinit_count = auto_reinit_count - 1; /* To forgive old errors */ grace_time = cur_time + 840000000; /* to wake up again 840 seconds from now */ if network_state > 1 then do; /* the IMP is absent or down */ call net_log_ (-100, "IMP is still ^a", imp_state); call net_log_ (1, "network_exec_: IMP is still ^a", imp_state); network_state = network_state + 1; if network_state = 4 /* has been through here twice */ then goto reinitialize; grace_time = cur_time + 300000000; /* to wakeup in 6 minutes to make another check */ end; call set_up_alarm; goto process_wakeup; /* to perform normal service, then block again */ process_imp_message: call net_$ncp_network_status (i, addr (status_structure), code); if (time_imp_state_changed > last_time) & (string (imp_special_message) ^= ""b) then do; if binary (imp_special_message.type, 4) = 2 then call decode_imp_going_down_message (); else call net_log_ (1, "network_exec_: Unexpected special IMP message of type ^d received.", binary (imp_special_message.type, 4)); end; last_time = time_imp_state_changed; goto block; /* This block is executed to investigate a changed IMP state */ process_changed_imp_state: imp_state = global_queue.state; if imp_state = "absent " then do; call net_log_ (-100, "IMP interface is absent. Please check configuration."); goto imp_down_wait; end; else if imp_state = "down " then /* */ imp_down_wait: do; call report_imp_state_changed; network_state = 2; auto_reinit_count = auto_reinit_count + 1; if auto_reinit_count > auto_reinit_threshold - 2 then do; call net_log_ (1, "network_exec_: Too many IMP state changes"); goto reinit1; end; grace_time = clock_ () + 300000000; call set_up_alarm; goto process_wakeup; end; else if imp_state = "up " then do; call report_imp_state_changed; call netp_$ncp_init (0, 2 /* reset */, code); network_state = 1; /* presumed up */ if code ^= 0 then do; call net_log_$net_error_log (1, code, "network_exec_", "Error while resetting NCP"); goto reinitialize; end; goto process_wakeup; end; /* else this is a fatal IMP state */ call report_imp_state_changed; reinitialize: auto_reinit_count = auto_reinit_count + 1; reinit1: if auto_reinit_count > auto_reinit_threshold then do; call net_log_ (1, "network_exec_: Too many auto reinitializations"); call net_log_ (1, "network_exec_: Sending the NCP down"); call ncp_down (code); goto NCP_down_enter_exec; end; call net_log_ (1, "network_exec_: Reinitializing the NCP"); auto_reinit_count = auto_reinit_count + 1; /* reinit subtracts 1 */ goto reinit_ncp; /* error handling code for network service code */ error: if network_state >= 1 then do; call net_log_$net_error_log (1, code, "network_exec_", ""); if (code = error_table_$net_not_up) | (code = error_table_$imp_down) | (code < 0) then do; call automatic_dump (); go to reinitialize; end; else if network_state > 0 then go to block; /* The network is still up */ end; NCP_down_enter_exec: network_state = -1; call net_log_ (-100, "Operator action required"); call network_exec; goto block; network_exec: /* It is assumed that no one outside of this module will */ entry; /* call this entry; if they do, they will find that an */ /* environment is not set up and they will get weird results. */ if ^exec_sw then do; /* first level of NETWORK EXEC */ call hcs_$get_process_usage (addr (new_process_usage), code); /* Fix meters to not include NETWORK EXEC */ process_usage = process_usage - new_process_usage; /* Aggregate arithmetic! */ exec_sw = "1"b; hold_sw = 0; ncp_state_modified = ""b; end; call ioa_ ("^/NETWORK PROCESSING SUSPENDED"); call iox_$control (iox_$user_io, "resetread", null (), (0)); read_console: call ioa_$nnl ("Enter Request: "); read_again: net_exec_grace_time = clock_ () + grace_time_increment; /* next time to return if no interaction */ call timer_manager_$alarm_call (net_exec_grace_time, ""b, alarm_wakeup); /* to set the timer */ linex = " "; /* Blank out buffer */ call ios_$read_ptr (addr (linex), length (linex), len); call timer_manager_$reset_alarm_call (alarm_wakeup); /* Don't leave EXEC mode while busy doing something! */ if len = 1 /* blank line aside from NL character */ then goto read_again; do i = 1 to len; if substr (linex, i, 1) ^= "" then goto find_req1; end; goto read_again; /* this was a blank line */ find_req1: j = index (substr (linex, i, len-i), " ") - 1; /* j is the length of the request name */ if j < 0 then j = len - i; /* end is the last char of this string */ req = substr (linex, i, j); token_ptr = addr (substr (linex, i+j)); /* points to next char following request name */ len = len-i-j; /* and no longer includes the NL character */ do i = lbound (request_list, 1) by 1 to hbound (request_list, 1); if req = request_list (i) then goto REQUEST (i); end; call ioa_ ("network_exec_: Unknown request ""^a""", req); go to read_console; return_from_network_exec: call ioa_ ("Normal network service resumed"); call iox_$control (iox_$user_io, "start", null, (0)); call timer_manager_$reset_alarm_call (alarm_wakeup); exec_sw = ""b; if ^ncp_state_modified then do; /* pick up from where we stopped */ call hcs_$get_process_usage (addr (new_process_usage), code); process_usage = process_usage + new_process_usage; /* This way we won't log time in NETWORK EXEC */ end; else do; call hcs_$get_process_usage (addr (process_usage), code); /* Reset metering */ wakeup_count = 0; end; grace_time = 0; /* to insure that alarm is established */ exec_sw, ncp_state_modified = ""b; goto net_exec_return; /* to re-enter at a restart point */ /* Request Processors */ REQUEST (1): rq_admin: hold_sw = hold_sw + 1; /* temporarily hold */ call condition_ ("any_other", standard_default_handler_); /* in case network handlers are still intact */ call enter_admin_mode_ (); call reversion_ ("any_other"); hold_sw = hold_sw - 1; /* und unset that hold */ go to read_console; REQUEST (2): rq_down: call net_log_ (1, "network_exec_: Manually turning off the NCP"); ncp_state_modified = "1"b; call ncp_down (code); goto read_console; REQUEST (3): rq_dump: call invoke_exec_com ("net_dump"); goto read_console; REQUEST (4): rq_hold: hold_sw = hold_sw + 1; /* Auto return from this invokation of NETWORK_EXEC is inhibited */ goto read_console; REQUEST (5): rq_host_list: call process_host_list (code); if code ^= 0 then call com_err_ (code, "network_exec_", "processing host list"); goto read_console; REQUEST (6): rq_host_off: host_on_off = 0; /* to turn off the hosts */ goto rq_host_common; REQUEST (7): rq_host_on: host_on_off = 1; /* to turn on the host */ rq_host_common: /* token_ptr and len have been set at find_request */ parse_past_blanks: do i = 1 to len; if substr (based_token, i, 1) ^= "" then goto found_start_of_token; end; goto read_console; found_start_of_token: token_ptr = addr (substr (based_token, i)); len1, len = len+1-i; /* get total line length from start of this token */ i = index (based_token, " "); if i ^= 0 then len = i-1; /* make based_token refer only to this token */ /* Note that len1 still contains length of entire remainder of line */ call change_host_state (based_token, host_on_off); token_ptr = addr (substr (based_token, len+1)); len = len1 /* the previous length of the entire line */ - len; goto parse_past_blanks; REQUEST (8): rq_logout: call net_log_ (1, "network_exec_: Manually turning off the NCP and logging out."); ncp_state_modified = "1"b; call ncp_down (0); call logout; /* Should not return from the logout call */ goto read_console; REQUEST (15): REQUEST (9): rq_re_init: call net_log_ (1, "network_exec_: Manually reinitializing the NCP."); ncp_state_modified = "1"b; auto_reinit_count = 0; call ncp_init (code); if code ^= 0 /* NCP did not come up */ then goto read_console; goto net_exec_auto_return; /* now go to normal daemon service */ REQUEST (10): rq_start: goto net_exec_auto_return; REQUEST (11): rq_survey: call invoke_exec_com ("net_survey"); goto read_console; REQUEST (12): rq_up: call net_log_ (1, "network_exec_: Manually turning on the NCP."); ncp_state_modified = "1"b; auto_reinit_count = 0; call ncp_up (code); goto read_console; REQUEST (13): rq_new_proc: call net_log_ (1, "network_exec_: Manually switching to new process."); call new_proc; /* This call should not return */ goto read_console; REQUEST (14): rq_comment: call net_log_ (0, "network_exec_: ^a", based_token); goto read_console; test_on: entry; testsw = "1"b; return; test_off: entry; testsw = "0"b; return; auto_dump_on: entry (); auto_dump_desired = "1"b; return; auto_dump_off: entry (); auto_dump_desired = "0"b; return; auto_reinit_off: entry (); auto_reinit_threshold = 0; return; auto_reinit_on: entry (); auto_reinit_threshold = default_auto_reinit_threshold; return; pi_error: call net_log_$net_error_log (1, code, "network_exec_", "Fatal error ^a during process initialization", char_error); call net_log_ (-100, "Can't initialize the Network Daemon process"); return; /* INTERNAL PROCEDURES FOLLOW */ alarm_wakeup: proc; /* This entry is called when the grace period timer goes off */ /* We check to see whether the grace period has been exceeded. If so, do a non-local goto to a point in network_exec that will return from NETWORK_EXEC. Otherwise, we return to proceed normally */ /* However, if the hold_sw is on or the network_state is down or crashed, we ignore the grace period and automatically return */ if hold_sw > 0 then return; if network_state < 1 then return; if clock_ () > net_exec_grace_time then goto net_exec_auto_return; end alarm_wakeup; append_link: proc; linex = ">system_library_network>" || entry_name; call hcs_$append_link (home_dir, entry_name, linex, code); end append_link; invoke_exec_com: procedure (p_ec_name); dcl p_ec_name character (*) parameter; call exec_com (p_ec_name); return; end invoke_exec_com; change_host_state: proc (p_host_id, p_state); declare p_host_id character (*) parameter; declare p_state fixed binary (1) parameter; declare host_number fixed binary (32) automatic; call host_id_$check_id (p_host_id, "0"b, host_number, "0"b, code); if code ^= 0 then do; token_err: call net_log_$net_error_log (1, code, "network_exec_", p_host_id); return; end; call netp_$ncp_host_comm (p_state, host_number, 1, code); if code ^= 0 then if (code = error_table_$net_not_up) | (code = error_table_$imp_down) then go to error; else go to token_err; end change_host_state; delete_event_channels: proc; do i = 1 to 3; if wait_list.channels (i) ^= 0 then do; call ipc_$delete_ev_chn (wait_list.channels (i), (0)); wait_list.channels (i) = 0; end; end; end delete_event_channels; ncp_down: procedure (p_err_code); /* take down the NCP */ dcl p_err_code fixed binary (35) parameter; call netp_$ncp_init (0, 0, p_err_code); network_state = 0; imp_state = ""; call delete_event_channels (); end ncp_down; ncp_init: procedure (p_err_code); /* initialize the NCP and turn on the hosts */ dcl p_err_code fixed binary (35) parameter; call ncp_down (p_err_code); call ncp_up (p_err_code); if p_err_code ^= 0 then return; call process_host_list (p_err_code); if p_err_code ^=0 then return; p_err_code = 0; /* force it to be OK */ call net_log_ (1, "network_exec_: Network Control Program in Operation."); end ncp_init; ncp_up: procedure (p_err_code); dcl p_err_code fixed binary (35) parameter; dcl init_count fixed bin; dcl initialization_wait_time fixed bin (71); dcl last_init_time fixed bin (71) internal static initial (0); network_state = 0; /* network not initialized */ imp_state = ""; call delete_event_channels; call hcs_$assign_channel (wait_list.channels (1), p_err_code); if p_err_code ^= 0 then do; char_error = "assc"; go to up_error; end; do i = 2 to 3; /* to create alarm and global event channels */ call ipc_$create_ev_chn (wait_list.channels (i), p_err_code); if p_err_code ^= 0 then do; char_error = "crec"; go to up_error; end; end; call ncp_$add_global_ev_chn (wait_list.channels (3), p_err_code); /* to get IMP state change messages */ if p_err_code ^= 0 then do; char_error = "ncps"; goto up_error; end; do init_count = 1 to 2; initialization_wait_time = 45 - divide (clock_ () - last_init_time, 1000000, 17, 0); if initialization_wait_time > 0 then call timer_manager_$sleep (initialization_wait_time, "11"b); call netp_$ncp_init (wait_list.channels (1), 1, p_err_code); last_init_time = clock_ (); if p_err_code = 0 then go to now_up; else call net_log_$net_error_log (1, p_err_code, "network_exec_", "Will re-try NCP initialization."); end; char_error = "ncpi"; go to up_error; now_up: network_state = 1; /* network now officially up */ return; up_error: network_state = -1; call net_log_ (-100, "Can't initialize Network Control Program"); call net_log_$net_error_log (1, p_err_code, "network_exec_", "Error ^a bringing up the NCP", char_error); call automatic_dump (); end ncp_up; /* This procedure enables initial communication with foreign */ /* hosts. It enables communication with all hosts which have the */ /* "communicate attribute" enabled in the Network host table. */ process_host_list: procedure (p_err_code); dcl p_err_code fixed binary (35) parameter; dcl host_num fixed binary (32), host_tablex fixed binary (17), comm_attr fixed binary (17), attributes bit (36); comm_attr = net_host_info_data_$communicate_attribute; if (comm_attr <= 0) | (comm_attr > length (attributes)) then do; call net_log_ (2, "network_exec_: Improper communicate attribute value. Unable to initialize communication with foreign hosts."); return; end; do host_tablex = 0 to net_host_table_$max_host_number; call dump_host_table_$get_host_number (host_tablex, host_num, p_err_code); if p_err_code = 0 then call dump_host_table_$get_attribute_string (host_num, attributes, p_err_code); if (p_err_code = 0) & (substr (attributes, comm_attr, 1) = "1"b) then do; call netp_$ncp_host_comm (1, host_num, 1, p_err_code); if (p_err_code = error_table_$net_not_up) | (p_err_code = error_table_$imp_down) then return; /* NCP went down while we weren't looking */ if p_err_code ^= 0 then call net_log_$net_error_log (1, p_err_code, "network_exec_", "Cannot enable host ^d (&^8.4b)", host_num, bit (fixed (host_num, 32), 32)); end; end; p_err_code = 0; return; end process_host_list; report_imp_state_changed: proc; call net_log_ (1, "network_exec_: IMP state has changed to ""^a""", imp_state); if imp_state ^= "up" then if imp_state ^= "down" then if imp_state ^= "absent" then call automatic_dump (); end report_imp_state_changed; interpret_IMP_status: procedure (p_status_word); declare p_status_word fixed binary (35) parameter; declare imp_status_message character (256) varying; call interpret_absi_status_ (unspec (p_status_word), ""b, imp_status_message, (0)); call net_log_$net_error_log (1, p_status_word, "network_exec_", "(^a)", imp_status_message); return; end interpret_IMP_status; decode_imp_going_down_message: procedure (); fixed_how_soon = binary (imp_special_message.how_soon, 4) * 5; if fixed_how_soon = 0 then log_message = ""; else log_message = " in " || convert_binary_integer_$decimal_string (fixed_how_soon) || " minutes"; fixed_why = binary (imp_special_message.why, 2); if fixed_why ^= 0 then log_message = log_message || " for " || imp_reason (fixed_why); fixed_how_long = binary (imp_special_message.how_long, 10) * 5; if fixed_how_long ^= 0 then do; log_message = log_message || "; Expected down time is"; if fixed_how_long > 90 then do; hours = divide (fixed_how_long, 60, 17, 0); log_message = log_message || " " || convert_binary_integer_$decimal_string (hours); fixed_how_long = fixed_how_long - hours * 60; if hours = 1 then log_message = log_message || " hour"; else log_message = log_message || " hours"; end; if fixed_how_long ^= 0 then log_message = log_message || " " || convert_binary_integer_$decimal_string (fixed_how_long) || " minutes"; end; call net_log_ (2, "network_exec_: IMP going down^a.", log_message); return; end decode_imp_going_down_message; automatic_dump: procedure; if auto_dump_desired then do; call net_log_ (1, "network_exec_: Automatically taking an NCP/IMP DIM dump."); call invoke_exec_com ("net_dump"); end; end automatic_dump; set_up_alarm: proc; call timer_manager_$alarm_wakeup (grace_time, "00"b, wait_list.channels (2)); end set_up_alarm; network_exec_handler: procedure (mc_ptr, condition_name, wc_mc_ptr, info_ptr, continue_sw); declare mc_ptr ptr, condition_name char (*), wc_mc_ptr ptr, info_ptr ptr, continue_sw bit (1) aligned; declare been_here_before bit (1) internal static initial (""b); declare condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char(*), ptr, ptr), terminate_process_ entry (char (*), ptr); declare 1 fatal_error_info aligned, 2 version fixed bin initial (0), 2 status_code fixed bin (35); declare (error_table_$termination_requested, error_table_$fatal_error) fixed bin (35) external static; if condition_name = "finish" then do; continue_sw = "0"b; return; end; if condition_name = "command_error" then call condition_interpreter_ (null, null, 0, 3, mc_ptr, condition_name, wc_mc_ptr, info_ptr); else do; if been_here_before then status_code = error_table_$termination_requested; else do; been_here_before = "1"b; call condition_interpreter_ (null, null, 0, 3, mc_ptr, condition_name, wc_mc_ptr, info_ptr); status_code = error_table_$fatal_error; end; call terminate_process_ ("fatal_error", addr (fatal_error_info)); end; end network_exec_handler; end network_exec_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved