



		    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
