



		    dump_host_table_.pl1            07/24/78  1452.2rew 07/24/78  1206.1       69588



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

dump_host_table_ : procedure;

/* Modified 3/31/78 by BSG for host number hashing */



% include host_info_structures;

dcl (phost_number, host_number) fixed bin (32);
dcl (seg_ptr, thing_ptr, struc_ptr, ptr1, loc_ptr) ptr;
dcl  location offset based;
dcl (index1, sub_code) fixed bin (35);
dcl (nullo, null, pointer, addr, length) builtin;
dcl  code fixed bin (35);
dcl  pofficial_name char (*);
dcl  len2 fixed bin (16);
dcl  pabbrev char (*);
dcl  pbit_string bit (*);
dcl  index fixed bin (35);
dcl  phost_name char (*);
dcl (pname_number, name_number) fixed bin (35);
dcl  pprop_name char (*);
dcl  pslotx fixed bin;
dcl  prop_name char (32);
dcl  prop_value char (256) var;
dcl (pprop_number, prop_number) fixed bin (35);
dcl  pprop_value char (*) var;
dcl (net_host_table_$header, net_host_table_$primary_data, net_host_table_$secondary_data) external static;
dcl  net_hash_index_ entry (ptr, fixed bin, fixed bin, fixed bin (35)) returns (fixed bin (35));
dcl  net_host_table_$max_host_number fixed bin (35) external;


dcl  net_error_table_$host_id_not_found external fixed bin (35);
dcl  net_error_table_$duplicate_host_id external fixed bin (35);
dcl  net_error_table_$end_of_list external fixed bin (35);
dcl  net_error_table_$host_table_inconsistent external fixed bin (35);
dcl  net_error_table_$no_such_host_property external fixed bin (35);
dcl  net_error_table_$invalid_host_number external fixed bin (35);
dcl  net_error_table_$host_table_not_init external fixed bin (35);
dcl  net_error_table_$host_not_known external fixed bin (35);
dcl net_error_table_$null_id fixed bin(35) external;



get_official_name: entry (phost_number, pofficial_name, code);


	host_number = phost_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	if struc_ptr -> info_structure.host_official_name_ptr = nullo then do;
	     pofficial_name = "";
	     code = net_error_table_$null_id;
	     return;
	end;
	else do;
	     ptr1 = pointer (struc_ptr -> info_structure.host_official_name_ptr, thing_ptr -> flipped_thing.info_space);
	     pofficial_name = ptr1 -> names_list.name;
	     code = 0;
	     return;
	end;



get_host_number:  entry (pslotx, phost_number, code);


	call init_seg (seg_ptr, thing_ptr);
	call get_host_from_slotx (pslotx, struc_ptr);
	if code = 0 then if struc_ptr -> info_structure.host_number < 0 then code = net_error_table_$host_not_known;
	else phost_number = struc_ptr -> info_structure.host_number;
	return;

get_abbrev: entry (phost_number, pabbrev, code);



	host_number = phost_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	if struc_ptr -> info_structure.host_abbrev_ptr = nullo then do;
	     pabbrev = "";
	     code = net_error_table_$null_id;
	     return;
	end;
	else do;
	     ptr1 = pointer (struc_ptr -> info_structure.host_abbrev_ptr, thing_ptr -> flipped_thing.info_space);
	     pabbrev = ptr1 -> names_list.name;
	     code = 0;
	     return;
	end;



get_attribute_string: entry (phost_number, pbit_string, code);



	host_number = phost_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	pbit_string = struc_ptr -> info_structure.freq_req_attributes;
	code = 0;
	return;



get_host_name: entry (phost_number, pname_number, phost_name, code);



/* command will repeatedly call this entry to pick up all the host names */
/* pname_number is the decimal number indicating which name on the list is requested */


	host_number = phost_number;
	name_number = pname_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	if name_number < 1 then do;
	     code = net_error_table_$host_id_not_found;
	     return;
	end;
	phost_name = "";
	if struc_ptr -> info_structure.names_ptr = nullo then do;
	     code = net_error_table_$end_of_list;
	     return;
	end;
	else do;
	     ptr1 = pointer (struc_ptr -> info_structure.names_ptr, thing_ptr -> flipped_thing.info_space);
	     do index = 1 to (name_number - 1);
		ptr1 = pointer (ptr1 -> names_list.next_name_ptr, thing_ptr -> flipped_thing.info_space);
		if ptr1 = null then do;
		     code = net_error_table_$end_of_list;
		     return;
		end;
	     end;
	     phost_name = ptr1 -> names_list.name;
	     code = 0;
	     return;
	end;



get_property: entry (phost_number, pprop_number, pprop_name, pprop_value, code);



/* command will call this entry repeatedly to pick up all the properties */
/* pprop_number is the decimal number indicating which property on the list is requested */


	host_number = phost_number;
	prop_number = pprop_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	if prop_number < 1 then do;
	     code = net_error_table_$no_such_host_property;
	     return;
	end;
	pprop_name = "";
	pprop_value = "";
	if struc_ptr -> info_structure.properties_ptr = nullo then do;
	     code = net_error_table_$end_of_list;
	     return;
	end;
	else do;
	     ptr1 = pointer (struc_ptr -> info_structure.properties_ptr, thing_ptr -> flipped_thing.info_space);
	     do index = 1 to (prop_number - 1);
		ptr1 = pointer (ptr1 -> properties_list.next_property_ptr, thing_ptr -> flipped_thing.info_space);
		if ptr1 = null then do;
		     code = net_error_table_$end_of_list;
		     return;
		end;
	     end;
	     pprop_name = ptr1 -> properties_list.property_name;
	     pprop_value = ptr1 -> properties_list.property_value;
	     code = 0;
	     return;
	end;



chkparm1:	procedure (host_number);


dcl  host_number fixed bin (32);


	     if host_number < 0 then do;
		code = net_error_table_$invalid_host_number;
		goto exit;
	     end;
	     return;
	end;



init_seg : procedure (seg_ptr, thing_ptr);



dcl (seg_ptr, thing_ptr) ptr;


	     seg_ptr = addr (net_host_table_$header);
	     if seg_ptr -> header.initialized = "0"b then do;
		code = net_error_table_$host_table_not_init;
		goto exit;
	     end;
	     if seg_ptr -> header.which_area = "0"b then thing_ptr = addr (net_host_table_$primary_data);
	     else thing_ptr = addr (net_host_table_$secondary_data);
	     return;
	end;



init_struc: procedure (host_number, struc_ptr);

dcl  host_number fixed bin (32);
dcl  struc_ptr ptr;
dcl  slotx fixed bin;
dcl  trial_slotx fixed bin;

	slotx = mod (host_number, net_host_table_$max_host_number + 1);
	do trial_slotx = slotx to net_host_table_$max_host_number,
		0 to slotx - 1;

	     call get_host_from_slotx (trial_slotx, struc_ptr);
	     if struc_ptr = null then go to lose;
	     if struc_ptr -> info_structure.host_number = host_number then return;
	end;

lose:	code = net_error_table_$host_not_known;
	go to exit;

end init_struc;

get_host_from_slotx: procedure (slotnum, struc_ptr);


dcl  slotnum fixed bin;
dcl  struc_ptr ptr;


	     code = 0;
	     if thing_ptr -> flipped_thing.host_number_table (slotnum) = nullo then do;
		code = net_error_table_$host_not_known;
		struc_ptr = null ();
		return;
	     end;
	     struc_ptr = pointer (thing_ptr -> flipped_thing.host_number_table (slotnum),
		thing_ptr -> flipped_thing.info_space);
	     return;
	end;







exit :	return;


     end;




		    host_id_.pl1                    05/16/80  1818.5rew 05/16/80  1817.1       34713



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

host_id_: procedure;

dcl (phost_number, host_number) fixed bin (32);
dcl  code fixed bin (35);
dcl (phost_name, phost_abbrev) char (*);
dcl  phost_id char (*);
dcl (poctsw, octsw, psymbsw) bit (1);
dcl  host_name char (32);
dcl  cv_proc variable entry (char (*), fixed bin (35)) returns (fixed bin (35));

dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_hex_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  dump_host_table_$get_official_name entry (fixed bin (32), char (*), fixed bin (35));
dcl  dump_host_table_$get_abbrev entry (fixed bin (32), char (*), fixed bin (35));
dcl  nhi_update_$search_hash_table_service entry (char (*), fixed bin (32), fixed bin (35));
dcl  net_error_table_$null_id fixed bin (35) external;


symbol:	entry (phost_number, phost_name, code);

/* this entry will convert input host number to official host name */

	call dump_host_table_$get_official_name (phost_number, phost_name, code);
	return;


number:	entry (phost_number, phost_name, code);

/* this entry will convert symbolic host  name to host number */

	call nhi_update_$search_hash_table_service (phost_name, phost_number, code);
	return;


abbrev:	entry (phost_number, phost_abbrev, code);

/* this entry will convert the input host number to the host abbreviation */

	call dump_host_table_$get_abbrev (phost_number, phost_abbrev, code);
	if code = net_error_table_$null_id then do;
						/* see if can use official name instead of missing abbrev */
	     call dump_host_table_$get_official_name (phost_number, host_name, code);
	     if code ^= 0 then do;
		code = net_error_table_$null_id;
		return;
	     end;
	     if substr (host_name, 5) = "" then do;	/* if official name is 4 chars or less, can use it */
		phost_abbrev = host_name;
		code = 0;
		return;
	     end;
	     else do;
		code = net_error_table_$null_id;
		return;
	     end;
	end;
	return;


check_id:	entry (phost_id, poctsw, phost_number, psymbsw, code);

/* this entry accepts a character string host id as input and will return the host number */

	if poctsw = "1"b
	then cv_proc = cv_oct_check_;
	else cv_proc = cv_dec_check_;
	if index (phost_id, "/") = 0
	then phost_number = cv_proc (phost_id, code);
	else do;
	     phost_number = 10 * 1f24b + cv_proc (before (phost_id, "/"), code) * 1f16b;
	     if code = 0
	     then phost_number = phost_number + cv_proc (after (phost_id, "/"), code);
	end;
	if code = 0 then do;			/* correct quess - input was numeric */
	     psymbsw = "0"b;			/* signal input was not symbolic name */
	     if phost_number < 512 then		/* Auld stiel */
		phost_number =
		10 * 16777216			/* ARPA NET */
		+ mod (phost_number, 64)		/* IMP number */
		+ 65536 * divide (phost_number, 64, 17, 0); /* Port number */

	     return;
	end;
	else if substr (phost_id, 1, 1) = "&" then do;	/* Hornig/Greenberg Host ID */
	     phost_number = cv_hex_check_ (rtrim (substr (phost_id, 2)), code);
	     if code = 0 then do;			/* Won */
		psymbsw = "0"b;
		return;
	     end;
	     go to trysearch;
	end;
	else do;					/* input was character string id so convert to host number */
trysearch:
	     call nhi_update_$search_hash_table_service (phost_id, phost_number, code);
	     psymbsw = "1"b;			/* signal character string input */
	     return;
	end;



     end;




		    list_sockets.pl1                09/27/79  1912.3rew 09/27/79  1025.6      162180



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

list_sockets:
lsc:
     procedure () options (variable);

/* This procedure lists the status of the sockets being used in a process.
   (By default, sockets which are only "activated" are not listed.)  Control
   arguments are provided to select subsets of the sockets for listing.
   */

/* Initial coding:	???? by D. M. Wells */
/* Last modified:	November 1974 by D. M. Wells in preparation for submission */
/* Last modified:	July 1974 by D. M. Wells to add -brief and -long control
		arguments that actually do something */
/* Last modified:	3 April 1974 by G. Palter to use large host numbers */


dcl  cur_state fixed binary (6);
dcl (num_of_args, num_of_sockets, table_indx, n_required_hosts) fixed binary;
dcl  err_code fixed binary (35);
dcl (admin_person, admin_project) character (32);
dcl (ncp_indx_arr_ptr, seg_ptr, sock_ptr, socket_table_ptr) pointer;

dcl 1 control_args aligned automatic,
    2 print_header bit (1),
    2 print_all bit (1),
    2 history bit (1),
    2 admin bit (1),
    2 long bit (1),
    2 hosts_specified bit (1);

dcl 1 info_struc aligned automatic,
    2 table_info (2),
      3 offset fixed binary (18),
      3 lenth fixed binary (18),
    2 buffer (1020) bit (36);

dcl 1 output_string unaligned automatic,
    2 local_socket_description,
      3 ncp_indx character (3),
      3 pad1 character (1),
      3 local_socket character (12),
    2 additional_local_description,
      3 local_pin character (3),
      3 pad22 character (1),
      3 read_or_write character (3),
    2 state character (12),
    2 foreign_socket_description,
      3 foreign_host character (12),
      3 pad27 character (1),
      3 foreign_socket character (12),
    2 connection_description,
      3 link character (4),
      3 pad4 character (1),
      3 allocation unaligned,
        4 mess_alloc character (5),
        4 pad42 character (1),
        4 bit_alloc character (10),
    2 flags unaligned,
      3 lock character (1),
      3 queue character (1),
      3 int_ok character (1),
      3 deac_sw character (1),
      3 spare character (1),
    2 process_group_id character (32);

dcl  NAME character (32) static options (constant) initial ("list_sockets");

dcl 1 socket_states (0 : 14) aligned  static options (constant),
    2 name character (12) initial (
	"?? -0- ??", "Assigned", "Listening", "RFC-received", "RFC-aborted",
	"RFC-sent", "Connected", "Close-wait", "Reject-wait", "Data-wait",
	"RFNM-wait", "Close-read", "?? -12- ??", "Broken", "Reset");

dcl  ncp_indx_arr (1 : 1) fixed binary (12) based;

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

dcl  required_hosts (num_of_args) fixed binary (32) based (required_hosts_ptr);
dcl  required_hosts_ptr pointer;

dcl 1 based_info_struc aligned based,
    2 table_info (2),
      3 offset fixed binary (18),
      3 lenth fixed binary (18),
    2 buffer (sys_info$max_seg_size-4) bit (36);

dcl 1 socket_table (1) aligned based like soct;

dcl  sys_info$max_seg_size fixed binary (18) external;

dcl (error_table_$area_too_small,
     error_table_$badopt,
     error_table_$noarg)
	fixed binary (35) external;
	
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  get_userid_ entry (bit (36) aligned, character (*), character (*), fixed binary, fixed binary (1), fixed binary (35));
dcl  host_id_$check_id entry (character (*), bit (1), fixed binary (32), bit (1), fixed binary (35));
dcl  host_id_$symbol entry (fixed binary (32), character (*), fixed binary (35));
dcl (ioa_,
     ioa_$rsnnl) entry () options (variable);
dcl (net_$ncp_status,
     netp_$ncp_priv_status) entry (fixed binary (12), fixed binary, pointer, fixed binary (18), fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));

dcl  cleanup condition;

dcl (addr, addrel, binary, index, length, null, reverse, rtrim,
     size, string, substr, verify)
	builtin;

/*  */

%include ncp_struc_defs;

/*  */

	required_hosts_ptr,
	     seg_ptr = null ();

	system_area_ptr = get_system_free_area_ ();

	on cleanup
	     call clean_up ();			/* in case of abort */


	call cu_$arg_count (num_of_args);

	n_required_hosts = 0;			/* number of hosts which must be listed */
	allocate required_hosts in (system_area);


	call process_options (cu_$arg_list_ptr ());


	call list_sockets_subr (addr (info_struc), size (info_struc), err_code);

	if err_code = error_table_$area_too_small then do;
						/* need larger buffer */
	     call get_temp_segment_ (NAME, seg_ptr, err_code);
		if err_code ^= 0 then do;
		     call com_err_ (err_code, NAME, "Getting buffer space.");
		     go to RETURN;
		end;

	     call list_sockets_subr (seg_ptr, sys_info$max_seg_size, err_code);

	     call release_temp_segment_ (NAME, seg_ptr, (0));
	end;


RETURN:
	call clean_up ();

	return;



clean_up:
	procedure ();

	     if seg_ptr ^= null () then
		call release_temp_segment_ (NAME, seg_ptr, (0));

	     if required_hosts_ptr ^= null () then
		free required_hosts in (system_area);

	     return;

	end clean_up;

/*  */

list_sockets_subr:
	procedure (bv_info_struc_ptr, bv_info_struc_size, bv_error_code);

dcl  bv_info_struc_ptr pointer parameter;
dcl  bv_info_struc_size fixed binary (18) parameter;
dcl  bv_error_code fixed binary (35) parameter;

dcl  mss_allocation fixed binary (16);
dcl  num_reportable_sockets fixed binary;
dcl  bit_allocation fixed binary (32);
dcl  host_name character (32);


	     if control_args.admin then
		call netp_$ncp_priv_status (5, 0, bv_info_struc_ptr, bv_info_struc_size, bv_error_code);
	     else call net_$ncp_status (5, 0, bv_info_struc_ptr, bv_info_struc_size, bv_error_code);

	     if bv_error_code ^= 0 then
		if bv_error_code = error_table_$area_too_small then
		     return;
		else do;
		     call com_err_ (bv_error_code, NAME, "Fetching socket data.");
		     go to RETURN;
		end;

	     num_of_sockets = bv_info_struc_ptr -> based_info_struc.table_info (1).lenth;

	     socket_table_ptr = addrel (bv_info_struc_ptr, bv_info_struc_ptr -> based_info_struc.table_info (1).offset);
	     ncp_indx_arr_ptr = addrel (bv_info_struc_ptr, bv_info_struc_ptr -> based_info_struc.table_info (2).offset);

	     num_reportable_sockets = 0;

	     do table_indx = 1 by 1 to num_of_sockets;
		if reportable_socket (addr (socket_table_ptr -> socket_table (table_indx))) then
		     num_reportable_sockets = num_reportable_sockets + 1;
		else socket_table_ptr -> socket_table (table_indx).procid = ""b;
	     end;

	     if num_reportable_sockets = 0 then
		call com_err_ (0, NAME, "No currently active sockets.");

	     else do;
		call ioa_ ("^d active socket^[s^;^]:", num_reportable_sockets, (num_reportable_sockets ^= 1));

		if control_args.print_header then do;
		     string (output_string) = "";
		     output_string.ncp_indx = " # ";
		     output_string.local_socket = "Local-Socket";
		     output_string.local_pin = "Pin";
		     output_string.read_or_write = "R/W";
		     output_string.state = "  State";
		     output_string.foreign_host = "Foreign-Host";
		     output_string.pad27 = "";
		     output_string.foreign_socket = "Forgn-Socket";
		     output_string.link = "Link";
		     string (output_string.flags) = "Flags";
		     string (output_string.allocation) = "M--Allocation--B";
		     if control_args.admin then
			output_string.process_group_id = "Process-Group-ID";
		     else output_string.process_group_id = "";
		     call put_out_line ();
		end;

		do table_indx = 1 by 1 to num_of_sockets;
		     sock_ptr = addr (socket_table_ptr -> socket_table (table_indx));

		     if sock_ptr -> soct.procid ^= ""b then do;
			string (output_string) = "";

			call ioa_$rsnnl ("^3d", output_string.ncp_indx, (0), ncp_indx_arr_ptr -> ncp_indx_arr (table_indx));

			cur_state = sock_ptr -> soct.state;
			output_string.state = socket_states (cur_state).name;

			if sock_ptr -> soct.lock then
			     output_string.lock = "l";
			if sock_ptr -> soct.queue then
			     output_string.queue = "q";
			if sock_ptr -> soct.int_ok then
			     output_string.int_ok = "i";
			if sock_ptr -> soct.deac_sw then
			     output_string.deac_sw = "d";

			if (((cur_state >= 5 & cur_state <= 12) | control_args.history)) & (sock_ptr -> soct.fsoc ^= ""b)
			then do;
			     call ioa_$rsnnl ("^4d", output_string.link, (0), binary (sock_ptr -> soct.linkn, 18));

			     mss_allocation = sock_ptr -> soct.malloc;
			     bit_allocation = sock_ptr -> soct.balloc;

			     call ioa_$rsnnl ("^5d", output_string.allocation.mess_alloc, (0), mss_allocation);
			     call ioa_$rsnnl ("^10d", output_string.allocation.bit_alloc, (0), bit_allocation);

			     call host_id_$symbol (binary (substr (sock_ptr -> soct.fsoc,
				     1, 32), 32), host_name, err_code);
			     if (err_code = 0) & (length (rtrim (host_name)) <= length (output_string.foreign_host)) then
				output_string.foreign_host = host_name;
			     else call ioa_$rsnnl ("H^d", output_string.foreign_host, (0), binary (substr (sock_ptr -> soct.fsoc, 1, 32), 32));

			     call ioa_$rsnnl ("^11d", output_string.foreign_socket, (0), binary (substr (sock_ptr -> soct.fsoc, 33, 32), 32));
			end;

			call ioa_$rsnnl ("^11d", output_string.local_socket, (0), binary (substr (sock_ptr -> soct.lsoc, 33, 32), 32));
			call ioa_$rsnnl ("^3d", output_string.local_pin, (0), binary (substr (sock_ptr -> soct.lsoc, 57, 8), 8));
			if sock_ptr -> soct.r_w then
			     output_string.read_or_write = " W ";
			else output_string.read_or_write = " R ";

			if control_args.admin then
			     output_string.process_group_id = identify_process_ (sock_ptr -> soct.procid);

			call put_out_line ();
		     end;
		end;
	     end;

	     return;

	end list_sockets_subr;

/*  */

put_out_line:
	procedure ();

dcl  output_line character (140) varying;


	     output_line = "";
	     output_line = output_line || string (output_string.local_socket_description);

	     if control_args.long then do;
		output_line = output_line || " ";
		output_line = output_line || string (additional_local_description);
	     end;

	     output_line = output_line || " ";
	     output_line = output_line || string (output_string.state);

	     output_line = output_line || " ";
	     output_line = output_line || string (output_string.foreign_socket_description);

	     if control_args.long then do;
		output_line = output_line || " ";
		output_line = output_line || string (output_string.connection_description);
	     end;

	     output_line = output_line || "  ";
	     output_line = output_line || string (output_string.flags);

	     if control_args.admin then do;
		output_line = output_line || " ";
		output_line = output_line || string (output_string.process_group_id);
	     end;

	     call ioa_ ("^a", output_line);

	     return;

	end put_out_line;

/*  */

reportable_socket:
	procedure (bv_sock_ptr) returns (bit (1) aligned);

dcl  bv_sock_ptr pointer parameter;

dcl  host_number fixed binary (32);
dcl  report_this_host bit (1) aligned;
dcl  sock_ptr pointer;
dcl  idx fixed binary;


	     sock_ptr = bv_sock_ptr;

	     if (^ control_args.print_all) & (sock_ptr -> soct.state = 1) then
		return ("0"b);

	     if n_required_hosts ^= 0 then do;
		if (^ control_args.history) & (sock_ptr -> soct.state < 5) then
		     return ("0"b);

		host_number = binary (substr (sock_ptr -> soct.fsoc, 1, 32), 32);
		report_this_host = "0"b;
		do idx = 1 to n_required_hosts;
		     if host_number = required_hosts (idx) then
			report_this_host = "1"b;
		end;

		if ^ report_this_host then
		     return ("0"b);
	     end;

	     if control_args.admin then
		if ^ userids_match (identify_process_ (sock_ptr -> soct.procid)) then
		     return ("0"b);

	     return ("1"b);

	end reportable_socket;

/*  */

process_options:
	procedure (bv_arg_list_ptr);

dcl  bv_arg_list_ptr pointer parameter;

dcl  arg_indx fixed binary;
dcl  arg_length fixed binary (21);
dcl  required_host_name character (32);
dcl  admin_person_group_id character (32);
dcl  arg_ptr pointer;

dcl  argument character (arg_length) unaligned based (arg_ptr);


	     string (control_args) = ""b;

	     control_args.print_header = "1"b;

	     do arg_indx = 1 by 1 to num_of_args;
		call cu_$arg_ptr_rel (arg_indx, arg_ptr, arg_length, err_code, bv_arg_list_ptr);
		     if err_code ^= 0 then do;
			call com_err_ (err_code, NAME, "Fetching argument #^d.", arg_indx);
			go to RETURN;
		     end;
		call process_control_arg ();
	     end;

	     if control_args.admin then do;		/* if admin, then parse the userid given */
		arg_length = index (admin_person_group_id, ".");
		if arg_length = 0
		then do;
		     admin_person = admin_person_group_id;
		     admin_project = "";
		end;
		else do;
		     admin_person = substr (admin_person_group_id, 1, arg_length - 1);
		     admin_project = substr (admin_person_group_id, arg_length + 1);

		     arg_length = index (admin_project, ".");
		     if arg_length ^= 0 then
			substr (admin_project, arg_length) = "";

		     if admin_person = "*" then
			admin_person = "";
		     if admin_project = "*" then
			admin_project = "";
		end;
	     end;

	     if control_args.hosts_specified then
		if n_required_hosts = 0 then do;
NO_HOST_NAMES:	     call com_err_ (error_table_$noarg, NAME,
			     "Host names after ""-host"".");
		     go to RETURN;
		end;

	     return;

/*  */

process_control_arg:
	     procedure ();

dcl  required_host_number fixed binary (32);
dcl  idx fixed binary;


		if (argument = "-admin") | (argument = "-am")
		     then do;
			control_args.admin = "1"b;
			call cu_$arg_ptr_rel (arg_indx + 1, arg_ptr, arg_length, err_code, bv_arg_list_ptr);
			if err_code ^= 0 then
			     admin_person_group_id = "*.*.*";
			else if substr (argument, 1, 1) = "-" then
			     admin_person_group_id = "*.*.*";
			else do;
			     admin_person_group_id = argument;
			     arg_indx = arg_indx + 1;
			end;
		     end;

		else if (argument = "-all") | (argument = "-a") then
		     control_args.print_all = "1"b;

		else if argument = "-host"
		     then do;
			control_args.hosts_specified = "1"b;

			do arg_indx = arg_indx + 1 by 1;
			     call cu_$arg_ptr_rel (arg_indx, arg_ptr, arg_length, err_code, bv_arg_list_ptr);
				if err_code ^= 0 then
				     return;

			     if substr (argument, 1, 1) = "-" then do;
				arg_indx = arg_indx - 1;
				return;
			     end;

			     call host_id_$check_id (argument, "0"b, required_host_number, (""b), err_code);
				if err_code ^= 0 then do;
				     call com_err_ (err_code, NAME, argument);
				     goto RETURN;
				end;

			     do idx = 1 to n_required_hosts;
				if required_host_number = required_hosts (idx) then
				     go to NEXT_HOST_NAME;
			     end;

			     n_required_hosts = n_required_hosts + 1;
			     required_hosts (n_required_hosts) = required_host_number;

NEXT_HOST_NAME:
			end;
		     end;

		else if (argument = "-history") | (argument = "-ht") then
		     control_args.history = "1"b;

		else if (argument = "-no_history") | (argument = "-nht") then
		     control_args.history = "0"b;

		else if (argument = "-header") | (argument = "-he") then
		     control_args.print_header = "1"b;

		else if (argument = "-no_header") | (argument = "-nhe") then
		     control_args.print_header = "0"b;

		else if (argument = "-long") | (argument = "-lg") then
		     control_args.long = "1"b;

		else if (argument = "-brief") | (argument = "-bf") then
		     control_args.long = "0"b;

		else do;
		     call com_err_ (error_table_$badopt, NAME, """^a""", argument);
		     go to RETURN;
		end;

	     return;

	     end process_control_arg;

	end process_options;

/*  */

identify_process_:
	procedure (bv_process_id) returns (character (32));

dcl  bv_process_id bit (36) aligned parameter;

dcl  anonymous fixed binary (1);
dcl  err_code fixed binary (35);
dcl (project, user) character (32);
dcl  user_id character (32) varying;


	     call get_userid_ (bv_process_id, user, project, (0), anonymous, err_code);
	     if err_code ^= 0 then
		return ("?.?");

	     if anonymous = 1 then
		user_id = "*";
	     else user_id = "";

	     user_id = user_id || rtrim (user);
	     user_id = user_id || ".";

	     user_id = user_id || rtrim (project);

	     return (user_id);

	end identify_process_;

/*  */

userids_match:
	procedure (bv_user_id) returns (bit (1) aligned);

dcl  bv_user_id character (32) parameter;

dcl  name_length fixed binary (21);
dcl (person_name, project_name) character (32);


	     if (admin_person = "") & (admin_project = "") then
		return ("1"b);

	     name_length = index (bv_user_id, ".");
	     if name_length = 0
	     then do;
		person_name = bv_user_id;
		project_name = "";
	     end;
	     else do;
		person_name = substr (bv_user_id, 1, name_length - 1);
		project_name = substr (bv_user_id, name_length + 1);

		name_length = index (project_name, ".");
		if name_length ^= 0 then
		     substr (project_name, name_length) = "";
	     end;

	     if (person_name = admin_person) & (project_name = admin_project) then
		return ("1"b);

	     if (person_name = admin_person) & (admin_project = "") then
		return ("1"b);

	     if (admin_person = "") & (admin_project = project_name) then
		return ("1"b);

	     return ("0"b);

	end userids_match;

     end list_sockets;




		    net.pl1                         09/23/77  1035.8rew 09/22/77  1715.0       79263



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

net:
          procedure ();

/*             "net" -- active function to return Network information.          */

/*        Originally created by D. M. Wells, Jan, 1976.                         */

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

     declare
         (host_num fixed binary (16),
          function_indx fixed binary (17),
          ncp_state fixed binary (17),
          net_userid fixed binary (24),
          arg_length fixed binary (24),
          err_code fixed binary (35),
          not_active_funct bit (1),
          caller_request character (16),
          host_name character (32),
          response character (300) varying,
          arg_ptr pointer,
          get_argument variable entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35)))
               automatic;

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

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

     declare
          COMMAND   character (32) initial ("net")
               internal static options (constant);

     declare
          function_name (5) character (16) internal static options (constant) initial (
                    "NCP_state", "userid", "official_name", "abbrev", "host_number");

     declare
	NCP_state_name (-1 : 2) character (8) varying internal static options (constant) initial (
		"CRASHED", "DOWN", "IMP-DOWN", "UP");

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

     declare
         (based_answer character (arg_length) varying,
          based_argument character (arg_length))
               based;

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

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

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

     declare
          active_fnc_err_ constant entry options (variable),
          com_err_ constant entry options (variable),
          convert_binary_integer_$decimal_string constant entry (fixed bin (35)) returns (char (12) varying),
          cu_$af_arg_ptr constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35)),
          cu_$af_return_arg constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35)),
          cu_$arg_ptr constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35)),
          host_id_$check_id constant entry (char (*), bit (1), fixed bin (16), bit (1), fixed bin (35)),
          host_id_$abbrev constant entry (fixed bin (16), char (*), fixed bin (35)),
          host_id_$symbol constant entry (fixed bin (16), char (*), fixed bin (35)),
          ioa_ constant entry options (variable),
          ncp_$get_userid constant entry (fixed bin (24), fixed bin (35)),
          ncp_$local_host_number constant entry (fixed bin (16), fixed bin (35)),
          net_$ncp_network_status constant entry (fixed bin (17), ptr, fixed bin (35));

     declare
          (hbound, index, length, null, substr)
               builtin;

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

          not_active_funct = "0"b;                          /* assume we were called as an active function    */

	call cu_$af_arg_ptr (1, arg_ptr, arg_length, err_code);
	if err_code = error_table_$not_act_fnc
          then do;
	     call cu_$arg_ptr (1, arg_ptr, arg_length, err_code);
	     not_active_funct = "1"b;
	     end;
          if not_active_funct
          then get_argument = cu_$arg_ptr;
          else get_argument = cu_$af_arg_ptr;

	if err_code ^= 0
          then goto report_error;

	caller_request = arg_ptr -> based_argument;

          do function_indx = 1 by 1 to hbound (function_name, 1)
                    while (caller_request ^= function_name (function_indx));
	     end;
          if function_indx > hbound (function_name, 1)
          then do;
	     if not_active_funct
               then call com_err_ (error_table_$badopt, COMMAND, """^a""", caller_request);
	     else call active_fnc_err_ (error_table_$badopt, COMMAND, """^a""", caller_request);
	     return;
               end;

	goto case (function_indx);

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

exit:
	if not_active_funct
          then do;
	     call ioa_ ("^a", response);
	     return;
	     end;

	call cu_$af_return_arg ((0), arg_ptr, arg_length, err_code);
	if err_code ^= 0
          then goto report_error;

	arg_ptr -> based_answer = response;

          return;

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

report_error:
	if not_active_funct
          then call com_err_ (err_code, COMMAND, "");
	else call active_fnc_err_ (err_code, COMMAND, "");

	return;

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

case (1):                                         /* return NCP state                                         */
          call net_$ncp_network_status (ncp_state, null (), err_code);

	if err_code ^= 0
	then goto report_error;

	if (ncp_state >= lbound (NCP_state_name, 1)) & (ncp_state <= hbound (NCP_state_name, 1))
	then response = NCP_state_name (ncp_state);
	else response = "UNKNOWN";

          goto exit;

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

case (2):                                         /* get Network userid                                       */
          call ncp_$get_userid (net_userid, err_code);
          if err_code ^= 0
          then goto report_error;

          response = convert_binary_integer_$decimal_string ((net_userid));

          goto exit;

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

case (3):                                         /* return official name of local or specified host          */
          call get_argument (2, arg_ptr, arg_length, err_code);
          if err_code = 0
          then call host_id_$check_id (arg_ptr -> based_argument, "0"b, host_num, (""b), err_code);
          else call ncp_$local_host_number (host_num, err_code);

          if err_code ^= 0
          then goto report_error;

          call host_id_$symbol (host_num, host_name, err_code);
          if err_code ^= 0
          then goto report_error;

          response = truncate_string (host_name);

          goto exit;

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

case (4):                                         /* return abbreviation of local or specified host           */
          call get_argument (2, arg_ptr, arg_length, err_code);
          if err_code = 0
          then call host_id_$check_id (arg_ptr -> based_argument, "0"b, host_num, (""b), err_code);
          else call ncp_$local_host_number (host_num, err_code);

          if err_code ^= 0
          then goto report_error;

          call host_id_$abbrev (host_num, host_name, err_code);
          if err_code ^= 0
          then goto report_error;

          response = truncate_string (host_name);

          goto exit;
                    /* * * * * * * * * * * * * * * * * * * */

case (5):                                         /* get net address (as number) of local or specified host   */
          call get_argument (2, arg_ptr, arg_length, err_code);
          if err_code = 0
          then call host_id_$check_id (arg_ptr -> based_argument, "0"b, host_num, (""b), err_code);
          else call ncp_$local_host_number (host_num, err_code);

          if err_code ^= 0
          then goto report_error;

          response = convert_binary_integer_$decimal_string ((host_num));

          goto exit;

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

truncate_string:
          procedure (p_string) returns (char (300) varying);

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

     declare
          p_string character (*)
               parameter;

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

     declare
          len fixed binary (24)
               automatic;

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

          len = index (p_string, " ") - 1;
          if len = -1
          then len = length (p_string);

          return (substr (p_string, 1, len));

end;      /* end truncate_string                           */

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

          /* end net                                       */
end;




		    net_host_info_data_.mexp        09/23/77  1035.8rew 09/22/77  1715.0       14706




          name      net_host_info_data_

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"      This data segment contains constant data useful in interpreting values
" in the network host table.
"
"      Originally created by D. M. Wells, September, 1975.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

          bool      always_print,400000

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

          &macro    define_attribute
          segdef    &0
          set       attribute_counter,attribute_counter+1
          vfd       36/attribute_counter
          zero      &2
          aci       "&1",32
          &end

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

          segdef    attribute_table

attribute_table:
          vfd       36/attribute_counter

          set       attribute_counter,0


communicate_attribute:        define_attribute    Communicate,always_print
server_attribute:             define_attribute    Server,0
user_attribute:               define_attribute    User,0
tip_attribute:                define_attribute    TIP,0
multics_attribute:            define_attribute    Multics,0
tenex_attribute:              define_attribute    TENEX,0
its_attribute:                define_attribute    ITS,0
poll_status_attribute:        define_attribute    Poll_Status,0
elf_attribute:                define_attribute    Elf,0
ibm_attribute:                define_attribute    IBM,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
          end




		    net_host_status.pl1             06/18/81  1440.4rew 06/18/81  0549.3       84636



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

/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
net_host_status:
nhs:
     procedure options (variable);

/*  Command to print NCP host status information.

   With no arguments, prints decimal host number, long (standard) host name, and state of
   all active hosts.  States are:

   OFF  Inactive.  Not printed (unless specifically requested).
   UP   Host has responded to reset  and is communicating.
   RST  Host has not responded to reset yet.
   DOWN The NCP has learned that this host is not communicating.

   The "-brief" option will print only the short host name and state of all active hosts.
   The "-admin" option will print information of interest to system programmers.

   If symbolic host names, or decimal host numbers, are given as arguments, info will be printed
   only about those hosts.

   If the "-state" option is specified, info will be printed only about those hosts in the
   desired state.

   Original version by Ed Meyer.

   A Pogran Program 09/12/72
   Sorting (algorithm by Paul Green) added 11/19/73 by KTP.
   "-state" option changed to take character string names instead of integers, 06/25/74 by KTP.
   Last modified 06/25/74 by KTP
   Modified 5/15/78 by Greenberg for large host id's.
   Modified 5/17/81 by C. Hornig for more hosts.
*/

declare  arg char (arglen) based (argptr),
         arglen fixed bin,
         argptr ptr;

declare  bpl pointer,
         bps pointer,
         code fixed bin (35),
         d fixed bin,
         host_index fixed bin (32),
         host_name char (32),
         hosts_specified bit (1) initial (""b),
         i fixed bin,
         j fixed bin,
         k fixed bin,
         longsw bit (1) initial (""b),
         briefsw bit (1) initial (""b),
         desired_state fixed bin initial (-1),
         lock_string char (12),
         link_string char (32),
         n_active_hosts fixed bin,
         namesw bit (1),
         nargs fixed bin,
         nhosts fixed bin initial (0),
         previous_d fixed bin,
         sorted bit (1) initial (""b),
         t fixed bin,
         this_host fixed bin (32),
         order_list (256) fixed bin,
         hosts (64) fixed bin (32);

declare  1 info_struc aligned,
	 2 it (2),
	   3 idx fixed bin (32),
	   3 len fixed bin,
	 2 buf (3000) fixed bin;

declare  idxlist (256) fixed bin (32) based;

declare  state_name (0:3) char (4) static options (constant) initial ("OFF", "UP", "RST", "DOWN");

declare  com_err_ entry options (variable),
         convert_binary_integer_$octal_string entry (fixed bin (35)) returns (char (13) varying),
         cu_$arg_count entry (fixed bin),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
         host_id_$abbrev entry (fixed bin (32), char (*), fixed bin (35)),
         host_id_$check_id entry (char (*), bit (1), fixed bin (32), bit (1), fixed bin (35)),
         host_id_$symbol entry (fixed bin (32), char (*), fixed bin (35)),
         ioa_ entry options (variable),
         net_$ncp_status entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin (35));

declare  (error_table_$badopt) fixed bin (35) external;

declare  (addr, addrel, bit, dimension, substr, fixed, divide, size) builtin;
%page;
	call cu_$arg_count (nargs);

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argptr, arglen, code);
	     if substr (arg, 1, 1) = "-"
	     then if /* case */ arg = "-long" | arg = "-lg" | arg = "-admin" then longsw = "1"b;
		else if arg = "-bf" | arg = "-brief" then briefsw = "1"b;
		else if arg = "-st" | arg = "-status" | arg = "-state" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, argptr, arglen, code);
		     if code = 0 then do;
			if /* case */ arg = "up" | arg = "UP" then desired_state = 1;
			else if arg = "rst" | arg = "RST" then desired_state = 2;
			else if arg = "down" | arg = "DOWN" then desired_state = 3;
			else if arg = "off" | arg = "OFF" then desired_state = 0;
			else do;
			     call com_err_ (0, "net_host_status",
				"The ""-state"" argument must be either UP, RST, DOWN, or OFF.");
			     return;
			     end;
			end;
		     else go to standard_error_return;
		     end;
		else do;
		     call com_err_ (error_table_$badopt, "net_host_status", arg);
		     return;
		     end;
	     else do;
		hosts_specified = "1"b;
		if nhosts = 64 then do;
		     call com_err_ (0, "net_host_status", "Too many hosts specified; max = 64.");
		     return;
		     end;
		else nhosts = nhosts + 1;
		call host_id_$check_id (arg, "0"b, hosts (nhosts), namesw, code);
		if code ^= 0 then do;
		     call com_err_ (code, "net_host_status", arg);
		     nhosts = nhosts - 1;
		     end;
		end;
	end;
	if hosts_specified
	then if nhosts = 0 then return;

	call net_$ncp_status (3, 0, addr (info_struc), size (info_struc), code);
	if code ^= 0 then go to standard_error_return;

	n_active_hosts = info_struc.it (1).len;
	bps = addrel (addr (info_struc), info_struc.it (1).idx);

	if nhosts = 0 then do;
	     call ioa_ ("^/^d active hosts:", n_active_hosts);
	     if n_active_hosts <= dimension (order_list, 1)
						/* Only so many entries in order list, can't sort if more hosts */
	     then do;
		do i = 1 to n_active_hosts;
		     order_list (i) = i;
		end;
		previous_d = n_active_hosts;
		do d = (2 * divide (n_active_hosts, 4, 17, 0) + 1) repeat (2 * divide (d, 4, 17, 0) + 1)
		     while (previous_d > 1);
		     previous_d = d;
		     do i = 1 to n_active_hosts - d;
			k = i + d;
			j = i;
up:
			if bps -> host_tb (order_list (j)).host_id > bps -> host_tb (order_list (k)).host_id
			then do;
			     t = order_list (k);
			     order_list (k) = order_list (j);
			     order_list (j) = t;
			     if j > d then do;
				k = j;
				j = j - d;
				go to up;
				end;
			     end;
		     end;
		end;
		sorted = "1"b;
		end;
	     end;

	if longsw then do;
	     bpl = addrel (addr (info_struc), info_struc.it (2).idx);
	     call ioa_ ("^/IDX^7xHost ID^14xState RLK WLK^14xLink Assignment^15xLock");
	     end;
	else call ioa_ ("");

	do i = 1 to n_active_hosts;
	     if sorted
	     then host_index = order_list (i);
	     else host_index = i;
	     this_host = fixed (bps -> host_tb (host_index).host_id, 32);
	     if nhosts ^= 0 then do;
		do j = 1 to nhosts;
		     if hosts (j) = this_host then do;
			hosts (j) = 0;
			go to check_this_one;
			end;
		end;
		go to next_one;
		end;
check_this_one:
	     if desired_state ^= -1
	     then if fixed (bps -> host_tb (host_index).host_state, 17) ^= desired_state then go to next_one;
	     if /* case */ longsw then do;
		call host_id_$symbol (this_host, host_name, code);
		if code ^= 0 then host_name = "";
		if bps -> host_tb (host_index).hlock = ""b
		then lock_string = "";
		else lock_string =
			convert_binary_integer_$octal_string (fixed (bps -> host_tb (host_index).hlock, 35));
		link_string = (32)".";
		do j = 1 to 32;
		     if bps -> host_tb (host_index).rlinkn (j) then substr (link_string, j, 1) = "A";
		end;
		call ioa_ ("^3d &^8.4b ^16a ^4a ^3d ^3d  ^4a ^4a ^4a ^4a ^4a ^4a ^4a ^4a  ^a",
		     bpl -> idxlist (host_index), bit (fixed (this_host, 32), 32), host_name,
		     state_name (fixed (bps -> host_tb (host_index).host_state, 17)),
		     fixed (bps -> host_tb (host_index).rlkidx, 17), fixed (bps -> host_tb (host_index).wlkidx, 17),
		     substr (link_string, 1, 4), substr (link_string, 5, 4), substr (link_string, 9, 4),
		     substr (link_string, 13, 4), substr (link_string, 17, 4), substr (link_string, 21, 4),
		     substr (link_string, 25, 4), substr (link_string, 29, 4), lock_string);
		end;
	     else if briefsw then do;
		call host_id_$abbrev (this_host, host_name, code);
		if code = 0
		then call ioa_ ("^4a ^a", host_name, state_name (fixed (bps -> host_tb (host_index).host_state, 17)));
		else call ioa_ ("&^8.4b ^a", bit (fixed (this_host, 32), 32),
			state_name (fixed (bps -> host_tb (host_index).host_state, 17)));
		end;
	     else do;
		call host_id_$symbol (this_host, host_name, code);
		if code ^= 0 then host_name = "";
		call ioa_ ("&^8.4b ^4a ^16a", bit (fixed (this_host, 32), 32),
		     state_name (fixed (bps -> host_tb (host_index).host_state, 17)), host_name);
		end;
next_one:
	end;

	do i = 1 to nhosts;
	     if hosts (i) ^= 0
	     then if ^briefsw then do;
		     call host_id_$symbol (hosts (i), host_name, code);
		     if code ^= 0 then host_name = "";
		     if longsw
		     then call ioa_ ("^5x&^8.4b ^16a OFF", bit (fixed (hosts (i), 32), 32), host_name);
		     else call ioa_ ("&^8.4b  OFF  ^16a", bit (fixed (hosts (i), 32), 32), host_name);
		     end;
		else do;
		     call host_id_$abbrev (hosts (i), host_name, code);
		     if code = 0
		     then call ioa_ ("^4a OFF", host_name);
		     else call ioa_ ("&^8.4b OFF", bit (fixed (hosts (i), 32), 32));
		     end;
	end;

	call ioa_ ("");
	return;

standard_error_return:
	call com_err_ (code, "net_host_status");
%page;
%include net_db_dec;
%include ncp_struc_defs;

     end net_host_status;




		    nhi_manager_.pl1                09/23/77  1035.8rew 09/22/77  1715.0       18180



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

nhi_manager_: procedure;
%include host_info_structures ;


dcl (seg_ptr, thing_ptr) ptr;
dcl  i fixed bin;
dcl (nullo, addr) builtin;
dcl (net_host_table_$header, net_host_table_$primary_data, net_host_table_$secondary_data) external static;
dcl  empty builtin;
dcl  code fixed bin (35);



/*  E__n_t_r_y: nhi_manager_$init_host_table

   This entry is called to initialize the data base net_host_table_ .             */



init_host_table: entry (code);



	seg_ptr = addr (net_host_table_$header);
	seg_ptr -> header.lock = "0"b;
	seg_ptr -> header.which_area = "0"b;
	seg_ptr -> header.needs_flipping = "0"b;
	seg_ptr -> header.time_last_flipped = 0;
	seg_ptr -> header.number_of_inconsistencies = 0;
	seg_ptr -> header.version_number = 2;
	thing_ptr = addr (net_host_table_$primary_data);
	do i = 0 to hbound (thing_ptr -> flipped_thing.host_number_table, 1);
	     thing_ptr -> flipped_thing.host_number_table (i) = nullo;
	end;
	do i = 0 to hbound (thing_ptr -> flipped_thing.hash_table, 1);
	     thing_ptr -> flipped_thing.hash_table (i) = nullo;
	end;
	thing_ptr -> flipped_thing.info_space = empty;
	thing_ptr = addr (net_host_table_$secondary_data);
	do i = 0 to hbound (thing_ptr -> flipped_thing.host_number_table, 1);
	     thing_ptr -> flipped_thing.host_number_table (i) = nullo;
	end;
	do i = 0 to hbound (thing_ptr -> flipped_thing.hash_table, 1);
	     thing_ptr -> flipped_thing.hash_table (i) = nullo;
	end;
	thing_ptr -> flipped_thing.info_space = empty;
	seg_ptr -> header.initialized = "1"b;
	code = 0;
	return;
     end;




		    nhi_update_.pl1                 05/01/80  2142.7rew 05/01/80  2126.1      241947



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

nhi_update_ : procedure ;




/* Written by Nancy Federman, 1975
   Modified 4/78 by Bernard Greenberg for hashed host numbers.
  Modified January 1980 by C. Hornig to call hash_index_.
*/


/* N__a_m_e: nhi_update_


   This procedure is used to update/maintain the date base net_host_table_ which
   contains information on the ARPA network hosts. The procedure locks the data base when
   updating it but maintains the consistency of the data base so that it may be read while
   being altered. These are the entry points :
   1) nhi_update_$add_host
   2) nhi_update_$set_official_host_name
   3) nhi_update_$add_host_name
   4) nhi_update_$delete_host_name
   5) nhi_update_$delete_host
   6) nhi_update_$set_abbrev
   7) nhi_update_$add_property
   8) nhi_update_$delete_property
   9) nhi_update_$set_attribute
   10) nhi_update_$search_hash_table_service




*/
%include host_info_structures ;




dcl  location offset based;
dcl  attribute_value bit (1);
dcl  pattribute_value bit (1);
dcl  pattribute_number fixed bin (35);
dcl  attribute_number fixed bin (35);
dcl  official_name char (32);
dcl  pofficial_name char (*);
dcl  pabbrev char (*);
dcl  abbrev char (32);
dcl  host_name char (32);
dcl (slotx, last_deleted_slotx) fixed bin;
dcl  phost_name char (*);
dcl  pproperty_name char (*);
dcl  property_name char (32);
dcl  pproperty_value char (*) var;
dcl  property_value char (256) var;
dcl  len2 fixed bin (16);
dcl (code, sub_code, index, index1) fixed bin (35);
dcl (struc_ptr, prev_ptr, ptr1, thing_ptr, seg_ptr, loc_ptr) ptr;
dcl (host_number, phost_number) fixed bin (32);
dcl (translate, null, nullo, mod, clock) builtin;
dcl (addr, offset, pointer, length, substr) builtin;
dcl  area condition;
dcl (net_host_table_$header, net_host_table_$primary_data, net_host_table_$secondary_data) external static;
dcl  hash_index_ entry (ptr, fixed bin, fixed bin, fixed bin (35)) returns (fixed bin (35));
dcl  net_host_table_$max_host_number fixed bin (35) external;

dcl  net_error_table_$duplicate_host_property fixed bin (35) external;
dcl  net_error_table_$duplicate_host_id fixed bin (35) external;
dcl  net_error_table_$abbrev_length_in_error fixed bin (35)external;
dcl  net_error_table_$host_already_known fixed bin (35) external ;
dcl  net_error_table_$host_id_not_found fixed bin (35) external;
dcl  net_error_table_$host_not_known fixed bin (35) external;
dcl  net_error_table_$host_table_full fixed bin (35) external;
dcl  net_error_table_$host_table_inconsistent fixed bin (35) external;
dcl  net_error_table_$host_table_not_init fixed bin (35) external;
dcl  net_error_table_$invalid_host_number fixed bin (35) external;
dcl  net_error_table_$no_such_host_property fixed bin (35) external;
dcl  net_error_table_$no_such_host_attribute fixed bin (35) external;




/*
   E__n_t_r_y: nhi_update_$add_host


   This entry is called to add a host entry to the data base. It accepts
   a decimal host number as input and returns a status code.                       */



add_host:	entry (phost_number, code);



	host_number = phost_number;
	call chkparm1 (host_number);			/* check validty of host_number */
	call init_seg (seg_ptr, thing_ptr);		/* point to segment, correct area and lock */
	call init_struc (host_number, struc_ptr); /* set slotx globally */
	if struc_ptr ^= null then do;
	     call unlock (seg_ptr -> header.lock);
	     code = net_error_table_$host_already_known;	/* entry already defined */
	     return;
	end;
	on area begin;
	     seg_ptr -> header.needs_flipping = "1"b;
	     code = net_error_table_$host_table_full;
	     goto exit;
	end;
	allocate info_structure in (thing_ptr -> flipped_thing.info_space) set (struc_ptr);
	revert area;
						/* null out structure  */
	struc_ptr -> info_structure.calendar_clock = clock ();
	struc_ptr -> info_structure.version_number = 1;
	struc_ptr -> info_structure.host_number = host_number;
	struc_ptr -> info_structure.host_official_name_ptr = nullo;
	struc_ptr -> info_structure.host_abbrev_ptr = nullo;
	struc_ptr -> info_structure.names_ptr = nullo;
	struc_ptr -> info_structure.freq_req_attributes = (36)"0"b;
	struc_ptr -> info_structure.properties_ptr = nullo;
						/* set struc_ptr into ptr array */
	if last_deleted_slotx ^< 0 then slotx = last_deleted_slotx;	/* Re-use old slots */
	thing_ptr -> flipped_thing.host_number_table (slotx) = offset (struc_ptr, thing_ptr -> flipped_thing.info_space);
	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;

exit:	call unlock (seg_ptr -> header.lock);
exit1:	return;



/*
   E__n_t_r_y: nhi_update_$set_official_host_name


   This entry is called to set the official host name, which can
   then be used to identify the host. The entry accepts a decimal host
   number and a character string of up to 32 characters as input and returns
   a status code.                                                          */



set_official_host_name: entry (phost_number, pofficial_name, code);



	host_number = phost_number;
	official_name = pofficial_name;
	call chkparm1 (host_number);			/* check validty of host_number */
	call init_seg (seg_ptr, thing_ptr);		/* pick up ptr to header & flipped thing */
	call init_struc (host_number, struc_ptr) ;	/* pick up ptr to structure */
	if official_name ^= "" then do;		/* see if new name is unique */
	     call search_hash_table (official_name, loc_ptr, index, sub_code);
	     if sub_code ^= 0 then do;		/* new name not unique */
		call unlock (seg_ptr -> header.lock);
		code = sub_code;
		return;
	     end;
	end;
	if struc_ptr -> info_structure.host_official_name_ptr ^= nullo then do;
						/* delete current official name */
	     ptr1 = pointer (struc_ptr -> info_structure.host_official_name_ptr, thing_ptr -> flipped_thing.info_space);
	     call search_hash_table (ptr1 -> names_list.name, loc_ptr, index1, sub_code);
	     if sub_code = 0 then do;			/* aauuggh */
		call unlock (seg_ptr -> header.lock);
		code = net_error_table_$host_table_inconsistent;
		seg_ptr -> header.number_of_inconsistencies = seg_ptr -> header.number_of_inconsistencies +1;
		return;
	     end;
	     call hash_table_delete (loc_ptr, index1);
	end;
	if official_name = "" then do;
	     struc_ptr -> info_structure.host_official_name_ptr = nullo;
	     struc_ptr -> info_structure.calendar_clock = clock ();
	end;
	else do;
	     on area begin;
		seg_ptr -> header.needs_flipping = "1"b;
		code = net_error_table_$host_table_full;
		goto exit;
	     end;
	     allocate names_list in (thing_ptr -> flipped_thing.info_space) set (ptr1);
	     revert area;
	     ptr1 -> names_list.next_name_ptr = nullo;
	     ptr1 -> names_list.next_hash_ptr = nullo;
	     ptr1 -> names_list.host_number = host_number;
	     ptr1 -> names_list.name = official_name;
	     struc_ptr -> info_structure.host_official_name_ptr = offset (ptr1, thing_ptr -> flipped_thing.info_space);
	     struc_ptr -> info_structure.calendar_clock = clock ();
	     call hash_table_add (ptr1, index);
	end;
	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;


/*
   E__n_t_r_y: nhi_update_$add_host_name


   This entry is called to add a name to the list of "other names"
   that can be used to identify this host. The entry accepts a decimal
   host number and a character string of up to 32 characters as input
   and returns a status code.                                                     */




add_host_name : entry (phost_number, phost_name, code);



	host_number = phost_number;
	host_name = phost_name;
	call chkparm1 (host_number);			/* chack validty of host_number */
	call init_seg (seg_ptr, thing_ptr);		/* pick up ptr to header & flipped thing */
	call init_struc (host_number, struc_ptr);
						/* pick up ptr to structure */
	call search_hash_table (host_name, loc_ptr, index, sub_code);
						/* see if host_id is unique */
	if sub_code ^= 0 then do;			/* name not unique */
	     call unlock (seg_ptr -> header.lock);
	     code = sub_code;
	     return;
	end;
	on area begin;
	     code = net_error_table_$host_table_full;
	     seg_ptr -> header.needs_flipping = "1"b;
	     goto exit;
	end;
	allocate names_list in (thing_ptr -> flipped_thing.info_space) set (ptr1);
	revert area;
	ptr1 -> names_list.next_hash_ptr = nullo;
	ptr1 -> names_list.name = host_name;
	ptr1 -> names_list.host_number = host_number;
	ptr1 -> names_list.next_name_ptr = struc_ptr -> info_structure.names_ptr; /* add to top of list */
	struc_ptr -> info_structure.names_ptr = offset (ptr1, thing_ptr -> flipped_thing.info_space);
	struc_ptr -> info_structure.calendar_clock = clock ();
	call hash_table_add (ptr1, index);
	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;



/*
   E__n_t_r_y: nhi_update_$delete_host_name


   This entry is called to remove a name from the list of "other names", making it
   unavailable for use in identifying this host. The entry accepts a decimal host
   number and a  character string of up to 32 characters and returns a status code.           */



delete_host_name : entry (phost_number, phost_name, code);



	host_number = phost_number;
	host_name = phost_name;
	call chkparm1 (host_number);			/* validate host_number */
	call init_seg (seg_ptr, thing_ptr);		/* get ptr to header & flipped thing */
	call init_struc (host_number, struc_ptr) ;	/* pick up ptr to structure */
	if struc_ptr -> info_structure.names_ptr = nullo then do; /* no elements on list */
	     call unlock (seg_ptr -> header.lock);
	     code = net_error_table_$host_id_not_found;
	     return;
	end;
	call search_hash_table (host_name, loc_ptr, index, sub_code);
	if sub_code = 0 then do;
	     call unlock (seg_ptr -> header.lock);
	     code = net_error_table_$host_id_not_found;
	     return;
	end;
						/* find name on names list and delete */
	prev_ptr = addr (struc_ptr -> info_structure.names_ptr);
	do ptr1 = pointer (struc_ptr -> info_structure.names_ptr, thing_ptr -> flipped_thing.info_space)
		repeat (pointer (ptr1 -> names_list.next_name_ptr, thing_ptr -> flipped_thing.info_space))
		while (ptr1 ^= null);
	     if ptr1 -> names_list.name = host_name then do; /* match found */
		call hash_table_delete (loc_ptr, index);
		prev_ptr -> location = ptr1 -> names_list.next_name_ptr;
		struc_ptr -> info_structure.calendar_clock = clock ();
		call unlock (seg_ptr -> header.lock);
		code = 0;
		return;
	     end;
	     prev_ptr = addr (ptr1 -> names_list.next_name_ptr);
	end;
	call unlock (seg_ptr -> header.lock);
	code = net_error_table_$host_id_not_found;
	return;



/*
   E__n_t_r_y: nhi_update_$delete_host


   This entry is called to remove a host entry from the data base, including all attributes
   and identifiers. The entry accepts a decimal host number as input and returns a status code  */



delete_host: entry (phost_number, code);



	host_number = phost_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	if struc_ptr = null () then do;
	     call unlock (seg_ptr -> header.lock);
	     code = net_error_table_$host_not_known;
	     return;
	end;
	struc_ptr -> info_structure.calendar_clock = clock ();
	if struc_ptr -> info_structure.host_official_name_ptr ^= nullo then do;
						/* remove official name from hash table */
	     ptr1 = pointer (struc_ptr -> info_structure.host_official_name_ptr, thing_ptr -> flipped_thing.info_space);
	     call search_hash_table (ptr1 -> names_list.name, loc_ptr, index, sub_code);
	     if sub_code = 0 then do;			/* name not found */
		call unlock (seg_ptr -> header.lock);
		code = net_error_table_$host_table_inconsistent;
		seg_ptr -> header.number_of_inconsistencies = seg_ptr -> header.number_of_inconsistencies+1;
		return;
	     end;
	     call hash_table_delete (loc_ptr, index);
	end;
	if struc_ptr -> info_structure.host_abbrev_ptr ^= nullo then do;
						/* remove abbrev from hash table */
	     ptr1 = pointer (struc_ptr -> info_structure.host_abbrev_ptr, thing_ptr -> flipped_thing.info_space);
	     call search_hash_table (ptr1 -> names_list.name, loc_ptr, index, sub_code);
	     if sub_code = 0 then do;			/* name not found */
		call unlock (seg_ptr -> header.lock);
		code = net_error_table_$host_table_inconsistent;
		seg_ptr -> header.number_of_inconsistencies = seg_ptr -> header.number_of_inconsistencies +1;
		return;
	     end;
	     call hash_table_delete (loc_ptr, index);
	end;
	if struc_ptr -> info_structure.names_ptr ^= nullo then do;
						/* delete all names form hash table */
	     do ptr1 = pointer (struc_ptr -> info_structure.names_ptr, thing_ptr -> flipped_thing.info_space)
		     repeat (pointer (ptr1 -> names_list.next_name_ptr, thing_ptr -> flipped_thing.info_space))
		     while (ptr1 ^= null);
		call search_hash_table (ptr1 -> names_list.name, loc_ptr, index, sub_code);
		if sub_code = 0 then do;		/* name not found-internal error */
		     call unlock (seg_ptr -> header.lock);
		     code = net_error_table_$host_table_inconsistent;
		     seg_ptr -> header.number_of_inconsistencies = seg_ptr -> header.number_of_inconsistencies+1;
		     return;
		end;
		call hash_table_delete (loc_ptr, index);
	     end;
	end;
	struc_ptr -> info_structure.calendar_clock = clock ();
	struc_ptr -> info_structure.host_number = -1;	/* this is now a deleted slot */

	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;



/*
   E__n_t_r_y: nhi_update_$set_abbrev


   This entry is called to set the four character abbreviation. The entry accepts
   a decimal host number and character string as input and returns a status code.           */



set_abbrev: entry (phost_number, pabbrev, code);



	abbrev = pabbrev;
	if abbrev ^= pabbrev then do;
	     code = net_error_table_$abbrev_length_in_error;
	     return;
	end;
	host_number = phost_number;
	call chkparm1 (host_number);
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	if abbrev ^= "" then do;			/* see if new abbrev unique id */
	     call search_hash_table (abbrev, loc_ptr, index, sub_code);
	     if sub_code ^= 0 then do;
		call unlock (seg_ptr -> header.lock);
		code = sub_code;
		return;
	     end;
	end;
	if struc_ptr -> info_structure.host_abbrev_ptr ^= nullo then do; /* delete current abbrev */
	     ptr1 = pointer (struc_ptr -> info_structure.host_abbrev_ptr, thing_ptr -> flipped_thing.info_space);
	     call search_hash_table (ptr1 -> names_list.name, loc_ptr, index1, sub_code);
	     if sub_code = 0 then do;
		call unlock (seg_ptr -> header.lock);
		code = net_error_table_$host_table_inconsistent;
		seg_ptr -> header.number_of_inconsistencies = seg_ptr -> header.number_of_inconsistencies+1;
		return;
	     end;
	     call hash_table_delete (loc_ptr, index1);
	end;
	if abbrev = "" then do;
	     struc_ptr -> info_structure.host_abbrev_ptr = nullo;
	     struc_ptr -> info_structure.calendar_clock = clock ();
	end;
	else do;
	     on area begin;
		code = net_error_table_$host_table_full;
		seg_ptr -> header.needs_flipping = "1"b;
		goto exit;
	     end;
	     allocate names_list in (thing_ptr -> flipped_thing.info_space) set (ptr1);
	     revert area;
	     ptr1 -> names_list.next_hash_ptr = nullo;
	     ptr1 -> names_list.next_name_ptr = nullo;
	     ptr1 -> names_list.host_number = host_number;
	     ptr1 -> names_list.name = abbrev;
	     struc_ptr -> info_structure.host_abbrev_ptr = offset (ptr1, thing_ptr -> flipped_thing.info_space);
	     struc_ptr -> info_structure.calendar_clock = clock ();
	     call hash_table_add (ptr1, index);
	end;
	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;



/*
   E__n_t_r_y: nhi_update_$add_property


   This entry is called to add a character string property name and value to the
   properties list for this host. The entry accepts a decimal host number, a character
   string property name of up to 32 characters , and a characters string property
   value of up to 256 characters and returns a status code.                             */



add_property: entry (phost_number, pproperty_name, pproperty_value, code);



	host_number = phost_number;
	property_name = pproperty_name;
	property_value = pproperty_value;
	call chkparm1 (host_number);			/* chack validty of host_number */
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	len2 = length (property_value);
	if struc_ptr -> info_structure.properties_ptr ^= nullo then do;
						/* look for duplicate properties */
	     do ptr1 = pointer (struc_ptr -> info_structure.properties_ptr, thing_ptr -> flipped_thing.info_space)
		     repeat (pointer (ptr1 -> properties_list.next_property_ptr, thing_ptr -> flipped_thing.info_space))
		     while (ptr1 ^= null);
		if ptr1 -> properties_list.property_name = property_name then do;
		     call unlock (seg_ptr -> header.lock);
		     code = net_error_table_$duplicate_host_property;
		     return;
		end;
	     end;
	end;
	on area begin;
	     seg_ptr -> header.needs_flipping = "1"b;
	     code = net_error_table_$host_table_full;
	     goto exit;
	end;
	allocate properties_list in (thing_ptr -> flipped_thing.info_space) set (ptr1);
	revert area;
	ptr1 -> properties_list.property_name = property_name;
	ptr1 -> properties_list.property_value = property_value;
	ptr1 -> properties_list.next_property_ptr = struc_ptr -> info_structure.properties_ptr;
	struc_ptr -> info_structure.properties_ptr = offset (ptr1, thing_ptr -> flipped_thing.info_space);
	struc_ptr -> info_structure.calendar_clock = clock ();
	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;



/*
   E__n_t_r_y: nhi_update_$delete_property


   This entry is called to delete a property (name and value) from the list of properties
   associated with this host. The entry accepts a decimal host number and character string
   property name as input and returns a status code.                                                       */



delete_property : entry (phost_number, pproperty_name, code);



	host_number = phost_number;
	property_name = pproperty_name;
	call chkparm1 (host_number);			/* validate host_number */
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr) ;	/* pick up ptr to structure */
						/* init will take error exit if entry not found */
	if struc_ptr -> info_structure.properties_ptr = nullo then do; /* no elements on list */
	     call unlock (seg_ptr -> header.lock);
	     code = net_error_table_$no_such_host_property;
	     return;
	end;
	prev_ptr = addr (struc_ptr -> info_structure.properties_ptr);
	do ptr1 = pointer (struc_ptr -> info_structure.properties_ptr, thing_ptr -> flipped_thing.info_space)
		repeat (pointer (ptr1 -> properties_list.next_property_ptr, thing_ptr -> flipped_thing.info_space))
		while (ptr1 ^= null);
	     if ptr1 -> properties_list.property_name = property_name then do;
						/* match found->delete element */
		prev_ptr -> location = ptr1 -> properties_list.next_property_ptr;
		struc_ptr -> calendar_clock = clock ();
		call unlock (seg_ptr -> header.lock);
		code = 0;
		return;
	     end;
	     prev_ptr = addr (ptr1 -> properties_list.next_property_ptr);
	end;
	call unlock (seg_ptr -> header.lock);
	code = net_error_table_$no_such_host_property;	/* no match found */
	return;



/*
   E__n_t_r_y: nhi_update_$set_attribute


   This entry is called to set a bit in the 36 bit frequently-requested-attributes string. The
   entry accepts a decimal host number and attribute number and an attribute value of "0"b or
   "1"b as input and returns a status code.                                                   */



set_attribute: entry (phost_number, pattribute_number, pattribute_value, code);



	host_number = phost_number;
	attribute_number = pattribute_number;
	attribute_value = pattribute_value;
	call chkparm1 (host_number);
	if ((attribute_number < 1) | (attribute_number > length (struc_ptr -> info_structure.freq_req_attributes))) then do;
	     code = net_error_table_$no_such_host_attribute;
	     return;
	end;
	call init_seg (seg_ptr, thing_ptr);
	call init_struc (host_number, struc_ptr);
	substr (struc_ptr -> info_structure.freq_req_attributes, attribute_number, 1) = attribute_value;
	call unlock (seg_ptr -> header.lock);
	code = 0;
	return;




init_seg : procedure (seg_ptr, thing_ptr);
						/* procedure to set lock, get ptr to segment  */
						/* and ptr to correct area */
dcl (seg_ptr, thing_ptr) ptr;
dcl  error_table_$invalid_lock_reset fixed bin (35) external;
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  status fixed bin (35);
						/*         */
	     seg_ptr = addr (net_host_table_$header);	/* pointer to segment */
	     if seg_ptr -> header.initialized = "0"b then do; /* segment not initialized */
		code = net_error_table_$host_table_not_init;
		goto exit1;
	     end;
	     call set_lock_$lock (seg_ptr -> header.lock, 0, status);
	     if ((status = 0) | (status = error_table_$invalid_lock_reset)) then do;
		if seg_ptr -> header.which_area = "0"b then thing_ptr = addr (net_host_table_$primary_data);
		else thing_ptr = addr (net_host_table_$secondary_data); /* addr of correct area */
		return;
	     end;
	     else do;
		code = status;			/* update already in progress ? */
		goto exit1;
	     end;
	end;




unlock:	procedure (lock);


/* procedure to unlock the specified lock                                  */



dcl  lock bit (36) aligned ;
dcl  set_lock_$unlock entry (bit (36)aligned, fixed bin (35));


	     call set_lock_$unlock (lock, 0);
	     return;
	end;



init_struc: procedure (host_number, struc_ptr);

dcl  host_number fixed bin (32);
dcl  struc_ptr ptr;
dcl  target_slotx fixed bin;

	target_slotx = mod (host_number, net_host_table_$max_host_number + 1);
	last_deleted_slotx = -1;
	do slotx = target_slotx to net_host_table_$max_host_number,
		0 to target_slotx - 1;

	     call get_host_from_slotx (slotx, struc_ptr);
	     if struc_ptr = null then return;		/* nobody home */
	     if struc_ptr -> info_structure.host_number = host_number then return;
	     if struc_ptr -> info_structure.host_number < 0 then last_deleted_slotx = slotx;
	end;

	code = net_error_table_$host_not_known;
	go to exit;

end init_struc;

get_host_from_slotx: procedure (slotnum, struc_ptr);


dcl  slotnum fixed bin;
dcl  struc_ptr ptr;


	     if thing_ptr -> flipped_thing.host_number_table (slotnum) = nullo then do;
		code = net_error_table_$host_not_known;
		struc_ptr = null ();
		return;
	     end;
	     struc_ptr = pointer (thing_ptr -> flipped_thing.host_number_table (slotnum),
		thing_ptr -> flipped_thing.info_space);
	     return;
	end;


chkparm1:	procedure (host_number);


dcl  host_number fixed bin (32);
	     if host_number < 0 then do;
		code = net_error_table_$invalid_host_number;
		goto exit1;
	     end;
	     return;

	end;




search_hash_table: procedure (name, loc_ptr, index, sub_code);



/* search_hash_table return values */



/* to avoid problem of upper and lower cases of same name - name is
   hashed  after being translated into upper case and all
   comparisons are on the upper case string, but the string is stored
   in the data structure exactly as typed                               */

/* code = 0->name not found */
/* code = duplicate_host_id->name found */

/* loc_ptr->location before the element of interest */



dcl (name, uc_name) char (32);
dcl  uc_string char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  lc_string char (26) init ("abcdefghijklmnopqrstuvwxyz");
dcl  ringno fixed bin init (4);
dcl (index, sub_code) fixed bin (35);
dcl (loc_ptr, ptr1) ptr;

	     uc_name = translate (name, uc_string, lc_string);
	     index = hash_index_(addr (uc_name), length (uc_name), ringno, seg_ptr -> header.number_of_buckets);
	     loc_ptr = addr (thing_ptr -> flipped_thing.hash_table (index));
	     if thing_ptr -> flipped_thing.hash_table (index) = nullo then do;
		sub_code = 0;
		return;
	     end;
						/* search for duplicate */
	     do ptr1 = pointer (thing_ptr -> flipped_thing.hash_table (index), thing_ptr ->
		     flipped_thing.info_space)
		     repeat (pointer (ptr1 -> names_list.next_hash_ptr, thing_ptr -> flipped_thing.info_space))
		     while (ptr1 ^= null);
		if translate (ptr1 -> names_list.name, uc_string, lc_string) = uc_name then do;
		     sub_code = net_error_table_$duplicate_host_id;
		     return;
		end;
		loc_ptr = ptr1;
	     end;
	     sub_code = 0;
	     return;
	end;



hash_table_add : procedure (ptr1, index);


dcl  index fixed bin (35);
dcl  ptr1 ptr;
						/* ptr1->element to be added */
						/* index is set by search_hash_table */
						/* add to top of list */

	     ptr1 -> names_list.next_hash_ptr = thing_ptr -> flipped_thing.hash_table (index);
	     thing_ptr -> flipped_thing.hash_table (index) = offset (ptr1, thing_ptr -> flipped_thing.info_space);
	end;



hash_table_delete: procedure (loc_ptr, index);



/* loc_ptr and index are set by search_hash_table procedure */
/* loc_ptr->element before the one to be deleted */


dcl  index fixed bin (35);
dcl (loc_ptr, ptr1) ptr;


	     ptr1 = pointer (loc_ptr -> location, thing_ptr -> flipped_thing.info_space);
						/* pick up ptr to element to be deleted */
	     loc_ptr -> location = ptr1 -> names_list.next_hash_ptr; /* delete item */
	end;




/*
   E__n_t_r_y: nhi_update_$search_hash_table_service


   This entry is called to aide the commmand level programs to convert
   a host_id into a host_number. It accepts a host_id as input and returns
   the decimal host number and a status code.                                                           */



search_hash_table_service: entry (pname, phost_number, code);


/* to serve command level programs */
/* will convert host_id to host_number */

dcl  pname char (*);
dcl  name char (32);


	name = pname;
	seg_ptr = addr (net_host_table_$header);
	if seg_ptr -> header.initialized = "0"b then do;
	     code = net_error_table_$host_table_not_init;
	     return;
	end;
	if seg_ptr -> header.which_area = "0"b
	then
	     thing_ptr = addr (net_host_table_$primary_data);
	else
	thing_ptr = addr (net_host_table_$secondary_data);
	call search_hash_table (name, loc_ptr, index, sub_code);
	if sub_code = 0 then do;			/* name not found */
	     code = net_error_table_$host_id_not_found;
	     return;
	end;
	ptr1 = pointer (loc_ptr -> location, thing_ptr -> flipped_thing.info_space);
						/* point to element */
	phost_number = ptr1 -> names_list.host_number;
	code = 0;
	return;





     end;




		    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
