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 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " ¯o 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