dump_logtbl.pl1 09/23/77 1033.7rew 09/22/77 1723.9 181341 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ dump_logtbl: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (num_args fixed binary (17), (contact_sockets, max_ttys) fixed binary (17), entry_indx fixed binary (17), err_code fixed binary (35), print_meters bit (1), print_history bit (1), (channel_match_name, service_match_name) character (32), ename character (32), dirname character (168), logp pointer) automatic; declare abort_command variable entry options (variable) initial (abort_command_invocation) automatic; /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare PROG character (32) varying initial ("dump_logtbl") internal static options (constant); /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */ /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare net_as_$log_table_name character (32) external static; declare (error_table_$badopt, error_table_$noarg, error_table_$segknown) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare com_err_ constant entry options (variable), cu_$arg_count constant entry (fixed bin (17)), cu_$arg_list_ptr constant entry () returns (ptr), cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr), cu_$gen_call constant entry (entry, ptr), date_time_ constant entry (fixed bin (71), char (*)), expand_pathname_ constant entry (char (*), char (*), char (*), fixed bin (35)), hcs_$initiate constant entry (char (*), char (*), char (*), fixed bin (2), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname constant entry (ptr, fixed bin (35)), ioa_ constant entry options (variable), match_star_name_ constant entry (char (*), char (*), fixed bin (35)); declare (addr, binary, null, rel, string, substr, unspec) builtin; /* * * * * STACK REFERENCES * * * * * * * * * * */ declare cleanup condition; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include log_tbl; % include net_as_states; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ err_code = 0; call cu_$arg_count (num_args); if num_args < 0 then do; call ioa_ ("Usage is:^/^10x^a -ctl_args-", (PROG)); return; end; logp = null (); call process_options (cu_$arg_list_ptr ()); on cleanup call cleanup_after_command (); call hcs_$initiate (dirname, ename, "", 0b, 1b, logp, err_code); if (err_code ^= 0) & (err_code ^= error_table_$segknown) then call abort_command (err_code, PROG, "^a>^a", dirname, ename); if logp -> ltbl.version_number ^= cur_ltbl_version_5 then call abort_command (0, PROG, "Improper version number ^d (sb ^d)", logp -> ltbl.version_number, cur_ltbl_version_5); call perform_function (); call cleanup_after_command (); return_to_caller: return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ perform_function: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ contact_sockets = logp -> ltbl.num_services; call ioa_ ("Contact Sockets = ^d.", contact_sockets); do entry_indx = 1 by 1 to contact_sockets; call dump_contact_socket_data (logp -> ltbl.contact_socket (entry_indx)); end; call ioa_ (""); max_ttys = logp -> ltbl.max_inuse; call ioa_ ("Active Pseudo-TTYs = ^d.", max_ttys); do entry_indx = 1 by 1 to max_ttys; call dump_pseudo_tty_data (logp -> ltbl.entry (entry_indx)); end; return; end; /* end perform_function */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dump_contact_socket_data: procedure (p_log_socket); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare 1 p_log_socket aligned parameter like cs; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (next_slot, slot_indx) fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call match_star_name_ (p_log_socket.log_type, service_match_name, err_code); if err_code ^= 0 then return; call ioa_ ("^/^a contact socket (service type ^d) listening on socket ^d.", p_log_socket.log_type, p_log_socket.service_type, p_log_socket.log_pin); call ioa_ ("^5xCurrent state is: ^a (^d).", SERVICE_states (p_log_socket.logger_state), p_log_socket.logger_state); call ioa_ ("^5xNCP socket info: index = ^d, ev chn = ^24.3b.", binary (p_log_socket.log_sock_handle, 35), unspec (p_log_socket.logger_event_chn)); if p_log_socket.logger_state_timeout ^= 0 then call ioa_ ("^5xState change timeout at ^a.", printable_time (p_log_socket.logger_state_timeout)); call ioa_ ("^5xService index = ^d (offset = ^o).", p_log_socket.service_index, binary (rel (addr (p_log_socket)), 18)); if print_meters then do; call ioa_ ("^5xNumber wakeups = ^d.", p_log_socket.num_logger_wakeups); call ioa_ ("^5xNumber contacts = ^d.", p_log_socket.num_logger_contacts); call ioa_ ("^5xNumber rejects = ^d.", p_log_socket.num_logger_rejects); call ioa_ ("^5xNumber force clears = ^d.", p_log_socket.num_force_clears); call ioa_ ("^5xNumber activations = ^d.", p_log_socket.num_activations); call ioa_ ("^5xNumber timeouts = ^d.", p_log_socket.num_timeouts); end; if print_history then do; next_slot = mod (p_log_socket.num_state_changes, dimension (p_log_socket.state_block, 1)); do slot_indx = next_slot by 1 to hbound (p_log_socket.state_block, 1), lbound (p_log_socket.state_block, 1) by 1 to next_slot - 1; if p_log_socket.state_block (slot_indx).entry_time ^= 0 then call print_contact_history_slot (p_log_socket.state_block (slot_indx)); end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ print_contact_history_slot: procedure (p_history_slot); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare 1 p_history_slot aligned parameter like cs.history.state_block; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare event_time character (16) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call date_time_ (p_history_slot.entry_time, event_time); call ioa_ ("^5x^18a^3d ^3d ^3d ^3d ^8a", event_time, binary (p_history_slot.netstate, 5), 0, 0, 0, p_history_slot.comment); return; end; /* end print_contact_history_slot */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end dump_contact_socket_data */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dump_pseudo_tty_data: procedure (p_ptty); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare 1 p_ptty aligned parameter like lt; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (next_slot, slot_indx) fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if p_ptty.active = PTTY_detached then return; call match_star_name_ (p_ptty.tty_name, channel_match_name, err_code); if err_code ^= 0 then do; if p_ptty.tty_state <= 2 then return; /* not connected, thus can't have service type */ call match_star_name_ (p_ptty.service_name, service_match_name, err_code); if err_code ^= 0 then return; end; call ioa_ ("^/Pseudo-TTY ^a (Network socket group = ^d).", p_ptty.tty_name, p_ptty.net_socket_group); if p_ptty.active ^= PTTY_attached then call ioa_ ("^5xChannel is in state ^a (^d).", PTTY_states (p_ptty.active), p_ptty.active); call ioa_ ("^5xTTY state is ^a (^d).", TTY_states (p_ptty.tty_state), p_ptty.tty_state); call ioa_ ("^5xLine state is ^a (^d).", LINE_states (p_ptty.line_state), p_ptty.line_state); call ioa_ ("^5xNCP socket: read index = ^d, write index = ^d,^/^16xevent channel = ^24.3b.", binary (p_ptty.sock_handle (READ), 35), binary (p_ptty.sock_handle (WRITE), 35), unspec (p_ptty.ncp_event_chn)); call ioa_ ("^5xTTY index = ^d (offset = ^o).", p_ptty.tty_index, binary (rel (addr (p_ptty)), 18)); call ioa_ ("^5xAS event channel: ^24.3b.", unspec (p_ptty.as_event_chn)); if p_ptty.line_state ^= LINE_CLOSED then do; call ioa_ ("^5xForeign socket: ^d,^d.", p_ptty.host_num, p_ptty.socket_num); if p_ptty.state_change_timeout ^= 0 then call ioa_ ("^5xState change timeout at: ^a", printable_time (p_ptty.state_change_timeout)); call ioa_ ("^5xContact was to contact socket ^d for ^a.", p_ptty.contact_pin, p_ptty.service_name); end; if p_ptty.line_state = LINE_UP_CONTROL then do; call ioa_ ("^5xOperating process: ^12.3b.", p_ptty.passed_off_process_id); /* ought to try to identify this process */ end; if p_ptty.tty_state = TTY_DIALED then do; call ioa_ ("^5xTerminal type: ^a (old-type ^d).", p_ptty.terminal_type_name, p_ptty.old_terminal_type); call ioa_ ("^5xCurrent modes: ^24.3b.", string (p_ptty.current_modes)); call ioa_ ("^5xSpecial control: ^12.3b.", string (p_ptty.special_control)); end; if p_ptty.tty_state = TTY_DIALED then do; if p_ptty.using_new_TELNET then call ioa_ ("^5xUsing new TELNET protocol."); else call ioa_ ("^5xNot using new TELNET protocol."); call ioa_ ("^5xTELNET receive options: ^12.3b.", string (p_ptty.option_in_effect (READ))); call ioa_ ("^5xTELNET transmit options: ^12.3b.", string (p_ptty.option_in_effect (WRITE))); end; if print_meters then do; call ioa_ ("^5xCumulative dialed-up time = ^.3f secs.", p_ptty.cumulative_dialed_up_time / 1.0e6); call ioa_ ("^5xLast dialup time = ^a.", printable_time (p_ptty.last_dialup_time)); call ioa_ ("^5xNumber dialups = ^d.", p_ptty.num_connections); call ioa_ ("^5xNumber socket activations = ^d.", p_ptty.num_activations); call ioa_ ("^5xNumber wakeups to NET AS = ^d.", p_ptty.num_wakeups_to_net_as); call ioa_ ("^5xNumber device signals sent to AS = ^d.", p_ptty.num_wakeups_to_as); call ioa_ ("^5xNumber ""listens"" issued = ^d.", p_ptty.num_listens); call ioa_ ("^5xNumber ""hangups"" issued = ^d.", p_ptty.num_hangup_orders); call ioa_ ("^5xNumber channel errors detected = ^d.", p_ptty.num_channel_errors); call ioa_ ("^5xNumber of force clears = ^d.", p_ptty.num_force_clears); end; if print_history then do; next_slot = mod (p_ptty.num_state_changes, dimension (p_ptty.state_block, 1)); do slot_indx = next_slot by 1 to hbound (p_ptty.state_block, 1), lbound (p_ptty.state_block, 1) by 1 to next_slot - 1; if p_ptty.state_block (slot_indx).entry_time ^= 0 then call print_ptty_history_slot (p_ptty.state_block (slot_indx)); end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ print_ptty_history_slot: procedure (p_history_slot); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare 1 p_history_slot aligned parameter like lt.history.state_block; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare event_time character (16) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call date_time_ (p_history_slot.entry_time, event_time); call ioa_ ("^5x^18a^3d ^3d ^3d ^3d ^8a", event_time, binary (p_history_slot.netstate, 5), 0, 0, 0, p_history_slot.comment); return; end; /* end print_ptty_history_slot */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end dump_pseudo_tty_data */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ printable_time: procedure (p_time) returns (char (16) varying); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_time fixed binary (71) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare date_time_string character (24) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call date_time_ (p_time, date_time_string); return (substr (date_time_string, 1, 16)); end; /* end printable_time */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_options: procedure (p_arg_list_ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_arg_list_ptr pointer parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (arg_indx fixed binary (17), arg_length fixed binary (24), arg_ptr pointer) automatic; /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare based_argument character (arg_length) based; /* * * * * * * * * * * * * * * * * * * * * * * * */ ename = net_as_$log_table_name; dirname = ">system_control_dir"; print_meters = "0"b; print_history = "0"b; channel_match_name = ""; /* Notice that blank is an illegal star name, and */ service_match_name = ""; /* and will always produce a non-zero error code */ do arg_indx = 1 repeat (arg_indx + 1) while (got_argument (arg_indx)); call process_control_argument (arg_ptr -> based_argument); end; if (channel_match_name = "") & (service_match_name = "") then channel_match_name, service_match_name = "**"; /* no match specified, match everything */ return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ got_argument: procedure (p_arg) returns (bit (1)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_arg fixed binary (17) /* index of the argument which we are to address */ parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$arg_ptr_rel (p_arg, arg_ptr, arg_length, err_code, p_arg_list_ptr); if err_code = 0 then return ("1"b); if err_code = error_table_$noarg then return ("0"b); call abort_command (err_code, (PROG), "Attempting to get argument #^d.", p_arg); end; /* end got_argument */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_control_argument: procedure (p_control_arg); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_control_arg character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (p_control_arg = "-channel") | (p_control_arg = "-chn") then do; arg_indx = arg_indx + 1; if ^ got_argument (arg_indx) then call abort_command (error_table_$noarg, PROG, "The -channel control argument requires a channel specification, e.g., net004."); channel_match_name = arg_ptr -> based_argument; return; end; if (p_control_arg = "-service") | (p_control_arg = "-svc") then do; arg_indx = arg_indx + 1; if ^ got_argument (arg_indx) then call abort_command (error_table_$noarg, PROG, "The -service control argument requires a service specification, e.g., TELNET."); service_match_name = arg_ptr -> based_argument; return; end; if (p_control_arg = "-pathname") | (p_control_arg = "-pn") then do; arg_indx = arg_indx + 1; if ^ got_argument (arg_indx) then call abort_command (err_code, PROG, "The -pathname control arg requires a pathname specification."); call expand_pathname_ (arg_ptr -> based_argument, dirname, ename, err_code); if err_code ^= 0 then call abort_command (err_code, PROG, "^a", arg_ptr -> based_argument); return; end; if (p_control_arg = "-meter") | (p_control_arg = "-mt") then do; print_meters = "1"b; return; end; if (p_control_arg = "-history") then do; print_history = "1"b; return; end; call abort_command (error_table_$badopt, (PROG), p_control_arg); end; /* end process_control_argument */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end process_options */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup_after_command: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ if logp ^= null () then call hcs_$terminate_noname (logp, (0)); return; end; /* end cleanup_after_command */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ abort_command_invocation: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$gen_call (com_err_, cu_$arg_list_ptr ()); call cleanup_after_command (); goto return_to_caller; end; /* end abort_command_invocation */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end dump_logtbl */ end;  dump_ncp_databases.pl1 09/23/77 1033.7rew 09/22/77 1724.6 56745 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ dump_ncp_databases: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ((imp_data_len, imp_tables_len, imp_dim_buf_len, net_db_len) fixed binary (18), err_code bit (36) aligned, date_time character (24), dump_id character (13), dump_directory character (168), (imp_data_ptr, imp_tables_ptr, imp_dim_buf_ptr, net_db_ptr) pointer) automatic; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare clock_ constant entry () returns (fixed bin (71)), com_err_ constant entry options (variable), date_time_ constant entry (fixed bin (71), char (*)), hcs_$add_acl_entries constant entry (char (*), char (*), ptr, fixed bin (17), bit (36) aligned), hcs_$make_seg constant entry (char (*), char (*), char (*), fixed bin (5), ptr, bit (36) aligned), hcs_$set_bc_seg constant entry (ptr, fixed bin (24), bit (36) aligned), hcs_$terminate_noname constant entry (ptr, bit (36) aligned), ioa_ constant entry options (variable), netp_$imp_data_base constant entry (ptr, fixed bin (1), ptr, fixed bin (18), ptr, fixed bin (1), ptr, fixed bin (18), ptr, fixed bin (1), ptr, fixed bin (18)), netp_$ncp_priv_status constant entry (fixed bin (17), fixed bin (18), ptr, fixed bin (18), bit (36) aligned); declare (addr, binary, null, size, substr) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include ncp_tables_descr_dcls; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dump_directory = ">user_dir_dir>Daemon>Network_Daemon>dumps"; call date_time_ (clock_ (), date_time); dump_id = substr (date_time, 11, 4) || "_" || substr (date_time, 1, 8); call ioa_ ("Dump id is ""^a"".", dump_id); call copy_out_segments (); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ copy_out_segments: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare 1 net_db_header aligned automatic like ncp_data_header_template; /* * * * * * * * * * * * * * * * * * * * * * * * */ imp_data_ptr = make_segment ("imp_data." || dump_id); imp_tables_ptr = make_segment ("imp_tables." || dump_id); imp_dim_buf_ptr = make_segment ("imp_dim_buf_." || dump_id); /* imp_wired_buffers_ptr = make_segment ("imp_wired_buffers." || dump_id); */ net_db_ptr = make_segment ("net_db_." || dump_id); call netp_$imp_data_base ((null ()), 1, imp_data_ptr, imp_data_len, (null ()), 1, imp_tables_ptr, imp_tables_len, (null ()), 1, imp_dim_buf_ptr, imp_dim_buf_len); call netp_$ncp_priv_status (20, 0, addr (net_db_header), size (net_db_header), err_code); if err_code ^= ""b then do; call com_err_ (err_code, "dump_ncp_databases", "Attempting to get size of net_db_"); return; end; if net_db_header.version_number >= 2 then net_db_len = binary (net_db_header.last_label_in_net_db); else net_db_len = binary (net_db_header.error_tbl, 18) + 8 * 136; call netp_$ncp_priv_status (20, 0, net_db_ptr, net_db_len, err_code); if err_code ^= ""b then do; call com_err_ (err_code, "dump_ncp_databases", "Attempting to copy net_db_"); return; end; call finish_segment (imp_data_ptr, imp_data_len); call finish_segment (imp_tables_ptr, imp_tables_len); call finish_segment (imp_dim_buf_ptr, imp_dim_buf_len); /* call finish_segment (imp_wired_buffers_ptr, imp_wired_buffers_len) */ call finish_segment (net_db_ptr, net_db_len); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ make_segment: procedure (bv_entry_name) returns (ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare bv_entry_name character (*) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare seg_ptr pointer automatic; declare 1 acl_entry (1) aligned automatic, 2 access_name character (32) unaligned initial ("*.CompNet.*"), 2 modes bit (36) aligned initial ("1"b), 2 zero_pad bit (36) aligned, 2 status_code bit (36) aligned; /* * * * * * * * * * * * * * * * * * * * * * * * */ call hcs_$make_seg (dump_directory, bv_entry_name, "", 01011b, seg_ptr, err_code); if err_code ^= ""b then return (seg_ptr); call hcs_$add_acl_entries (dump_directory, bv_entry_name, addr (acl_entry), 1, err_code); return (seg_ptr); end make_segment; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ finish_segment: procedure (bv_seg_ptr, bv_seg_len); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (bv_seg_len fixed binary (18), bv_seg_ptr pointer) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call hcs_$set_bc_seg (bv_seg_ptr, bv_seg_len * 36, err_code); call hcs_$terminate_noname (bv_seg_ptr, err_code); bv_seg_ptr = null (); return; end finish_segment; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end copy_out_segments; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end dump_ncp_databases;  print_ncp_errors.pl1 08/21/79 1930.4rew 08/21/79 1745.0 208035 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ print_ncp_errors: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (extra_info_size fixed binary (17), (latest_error_indx, num_of_args, num_of_errors, table_indx) fixed binary (17), latest_error_time fixed binary (71), err_code fixed binary (35), (admin_person, admin_project) character (32), (ncp_indx_arr_ptr, seg_ptr, entry_ptr, error_array_ptr) pointer) automatic; declare 1 control_args aligned automatic, 2 print_header bit (1), 2 print_all bit (1), 2 history bit (1), 2 host_specification aligned, 3 required_host bit (1), 3 report_host bit (256), /* sb: (0 : 255) bit (1), but pl1 bugs */ 2 admin bit (1), 2 format bit (2); declare 1 info_struc aligned automatic, 2 table_info (2), 3 offset fixed binary (18), 3 length fixed binary (18), 2 buffer (1032) bit (36); /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare 1 error_states (0 : 14) aligned internal static, 2 name character (12) initial ( "????", "Assigned", "Listening", "RFC-received", "RFC-aborted", "RFC-sent", "Connected", "Close-wait", "Reject-wait", "Data-wait", "RFNM-wait", "Close-read", "????", "Broken", "Reset"); /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare ncp_indx_arr (1 : 1) fixed binary (12) based; declare 1 error_entry aligned based, 2 process_group_id character (32) unaligned, 2 condition character (32) unaligned, 2 clock_time fixed binary (71), 2 error_number fixed binary (17), 2 padding (5) fixed binary (35), 2 mc_cond (32) bit (36) unaligned, 2 info_data aligned, 3 fatal_code fixed binary (35), 3 fatal_message character (28) aligned, 2 proc_slot aligned like pdt, 2 gdt_data aligned like gdt, 2 extra_info (extra_info_size) bit (36) aligned; declare 1 error_array (1 : 8) aligned based like error_entry; declare 1 based_info_struc aligned based, 2 table_info (2), 3 offset fixed binary (18), 3 length fixed binary (18), 2 buffer (65532) bit (36); /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare iox_$user_output pointer external static; declare (error_table_$area_too_small, error_table_$badopt) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare com_err_ constant entry options (variable), convert_binary_integer_$decimal_string constant entry (fixed bin (35)) returns (char (12) varying), convert_status_code_ constant entry (fixed bin (35), char (8) aligned, char (100) aligned), cu_$arg_count constant entry (fixed bin (17)), cu_$arg_list_ptr constant entry () returns (ptr), cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr), date_time_ constant entry (fixed bin (71), char (*)), dump_seg_ constant entry (ptr, ptr, fixed bin (19), fixed bin (19), bit (4)), get_pdir_ constant entry () returns (char (168) aligned), hcs_$delentry_file constant entry (char (*), char (*), fixed bin (35)), hcs_$make_seg constant entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), host_id_$symbol constant entry (fixed bin (9), char (*), fixed bin (35)), host_id_$check_id constant entry (char (*), bit (1), fixed bin (16), bit (1), fixed bin (35)), identify_process_ constant entry (fixed bin (35)) returns (char (32)), ioa_ constant entry options (variable), ioa_$rsnnl constant entry options (variable), ncp_$version constant entry () returns (fixed bin (17)), netp_$ncp_priv_status constant entry (fixed bin (12), fixed bin (17), ptr, fixed bin (18), fixed bin (35)); declare (addr, addrel, binary, dimension, divide, index, length, size, string, substr, unspec) builtin; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include ncp_process_dcls; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$arg_count (num_of_args); if ncp_$version () >= 4 then extra_info_size = 24; else extra_info_size = 0; call process_options (cu_$arg_list_ptr ()); call print_ncp_errors_subr (addr (info_struc), size (info_struc), err_code); if err_code = error_table_$area_too_small then do; call hcs_$make_seg (get_pdir_ (), "print_ncp_errors_temp_", "", 01011b, seg_ptr, err_code); call print_ncp_errors_subr (seg_ptr, 65536, err_code); if err_code ^= 0 then goto print_error_message; call hcs_$delentry_file (get_pdir_ (), "print_ncp_errors_temp_", err_code); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ print_error_message: call com_err_ (err_code, "print_ncp_errors", ""); return_to_caller: return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ print_ncp_errors_subr: procedure (p_info_struc_ptr, p_info_struc_size, p_error_code); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_info_struc_size fixed binary (18), p_error_code fixed binary (35), p_info_struc_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare num_reportable_errors fixed binary (17) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call netp_$ncp_priv_status (7, 0, p_info_struc_ptr, p_info_struc_size, p_error_code); if p_error_code ^= 0 then do; if p_error_code = error_table_$area_too_small then return; goto print_error_message; end; num_of_errors = p_info_struc_ptr -> based_info_struc.table_info (1).length; error_array_ptr = addrel (p_info_struc_ptr, p_info_struc_ptr -> based_info_struc.table_info (1).offset); ncp_indx_arr_ptr = addrel (p_info_struc_ptr, p_info_struc_ptr -> based_info_struc.table_info (2).offset); num_reportable_errors = 0; latest_error_time = 0; do table_indx = 1 by 1 to num_of_errors; if reportable_error (addr (error_array_ptr -> error_array (table_indx))) then do; num_reportable_errors = num_reportable_errors + 1; if latest_error_time < error_array_ptr -> error_array (table_indx).clock_time then do; latest_error_time = error_array_ptr -> error_array (table_indx).clock_time; latest_error_indx = table_indx; end; end; else error_array_ptr -> error_array (table_indx).clock_time = 0; end; if num_reportable_errors = 0 then call ioa_ ("No Network Control Program errors."); else do; if num_reportable_errors = 1 then call ioa_ ("1 Network Control Program error."); else call ioa_ ("^d Network Control Program errors.", num_reportable_errors); call ioa_ (""); do table_indx = latest_error_indx by -1 to 1, num_of_errors by -1 to latest_error_indx + 1; entry_ptr = addr (error_array_ptr -> error_array (table_indx)); if entry_ptr -> error_entry.clock_time ^= 0 then call dump_error_entry (entry_ptr); end; end; return; end; /* end print_ncp_errors_subr */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dump_error_entry: procedure (p_entry_ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_entry_ptr pointer parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (foreign_host_number fixed binary (9), error_number fixed binary (17), error_time fixed binary (71), foreign_socket bit (64), error_time_string character (24), (error_condition, error_process_group_id) character (32), foreign_host character (32), error_code_message character (100) aligned, entry_ptr pointer) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ entry_ptr = p_entry_ptr; error_number = entry_ptr -> error_entry.error_number; error_condition = entry_ptr -> error_entry.condition; error_process_group_id = entry_ptr -> error_entry.process_group_id; error_time = entry_ptr -> error_entry.clock_time; call date_time_ (error_time, error_time_string); if error_condition ^= "ncp_error" then do; call ioa_ ("Error # ^d: ""^a"" caused by ""^a"" at ^a.", error_number, error_condition, error_process_group_id, error_time_string); end; else do; call convert_status_code_ (entry_ptr -> error_entry.info_data.fatal_code, (""), error_code_message); error_condition = entry_ptr -> error_entry.info_data.fatal_message; call ioa_ ("NCP Software error # ^d: ""^a -- ^a"" caused by ^a at ^a.", error_number, error_code_message, error_condition, error_process_group_id, error_time_string); foreign_socket = entry_ptr -> error_entry.gdt_data.fsoc; if foreign_socket ^= ""b then do; foreign_host_number = binary (substr (foreign_socket, 1, 32)); call host_id_$symbol (foreign_host_number, foreign_host, err_code); if err_code ^= 0 then foreign_host = "HOST-" || convert_binary_integer_$decimal_string ((foreign_host_number)); call ioa_ (" Foreign socket (^d at ^a) was in state ^a", binary (substr (foreign_socket, 33, 32), 32), foreign_host, (error_states.name (binary (entry_ptr -> error_entry.state, 8)))); end; end; if control_args.format ^= "01"b then do; if string (entry_ptr -> error_entry.mc_cond) ^= ""b then do; call ioa_ (" Machine conditions:"); call dump_words (addr (entry_ptr -> error_entry.mc_cond), dimension (entry_ptr -> error_entry.mc_cond, 1)); end; if unspec (entry_ptr -> error_entry.info_data) ^= ""b then do; call ioa_ ("Info Data Structure"); call dump_words (addr (entry_ptr -> error_entry.info_data), divide (length (unspec (entry_ptr -> error_entry.info_data)), 36, 24, 0)); end; if unspec (entry_ptr -> error_entry.proc_slot) ^= ""b then do; call ioa_ ("Process Table Entry"); call dump_words (addr (entry_ptr -> error_entry.proc_slot), size (addr (entry_ptr -> error_entry.proc_slot) -> pdt)); end; if unspec (entry_ptr -> error_entry.gdt_data) ^= ""b then do; call ioa_ ("Global Data Table"); call dump_words (addr (entry_ptr -> error_entry.gdt_data), size (addr (entry_ptr -> error_entry.gdt_data) -> gdt)); end; end; call ioa_ (""); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dump_words: procedure (p_start_ptr, p_length); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_length fixed binary (19), p_start_ptr pointer) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call dump_seg_ (iox_$user_output, p_start_ptr, 0, p_length, "0010"b); return; end; /* end dump_words */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end dump_error_entry */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reportable_error: procedure (p_entry_ptr) returns (bit (1) aligned); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_entry_ptr pointer parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (host_number fixed binary (16), report_this_host bit (1), entry_ptr pointer) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ entry_ptr = p_entry_ptr; if control_args.required_host then if binary (control_args.report_host, 8) ^= entry_ptr -> error_entry.gdt_data.gq_host_id then return ("0"b); if control_args.admin then if ^ userids_match (entry_ptr -> error_entry.process_group_id) then return ("0"b); return ("1"b); end; /* end reportable_error */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_options: procedure (p_arg_list_ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_arg_list_ptr pointer parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (arg_indx fixed binary (17), arg_length fixed binary (24), required_host_name character (32), admin_person_group_id character (32), arg_ptr pointer) automatic; /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare based_argument character (arg_length) based; /* * * * * * * * * * * * * * * * * * * * * * * * */ control_args.print_header = "1"b; control_args.print_all = "0"b; control_args.history = "0"b; control_args.required_host = "0"b; control_args.report_host = ""b; control_args.admin = "0"b; control_args.format = "00"b; do arg_indx = 1 by 1 to num_of_args; call cu_$arg_ptr_rel (arg_indx, arg_ptr, arg_length, err_code, p_arg_list_ptr); if err_code ^= 0 then goto print_error_message; call process_control_arg (); end; if control_args.format = "00"b then control_args.format = "10"b; /* default is full */ if control_args.required_host then if control_args.report_host = ""b then goto host_requires_an_argument; 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; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ host_requires_an_argument: call com_err_ (err_code, "print_ncp_errors", "Parameter to the -host control argument."); goto return_to_caller; /* * * * * * * * * * * * * * * * * * * * * * * * */ unknown_argument: call com_err_ (error_table_$badopt, "print_ncp_errors", arg_ptr -> based_argument); goto return_to_caller; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_control_arg: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare required_host_number fixed binary (16) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (arg_ptr -> based_argument = "-admin") | (arg_ptr -> based_argument = "-am") then do; control_args.admin = "1"b; call cu_$arg_ptr_rel (arg_indx + 1, arg_ptr, arg_length, err_code, p_arg_list_ptr); if err_code ^= 0 then admin_person_group_id = "*.*.*"; else if substr (arg_ptr -> based_argument, 1, 1) = "-" then do; /* arg starts with "-", assume not admin name */ admin_person_group_id = "*.*.*"; end; else do; admin_person_group_id = arg_ptr -> based_argument; arg_indx = arg_indx + 1; end; return; end; if (arg_ptr -> based_argument = "-all") | (arg_ptr -> based_argument = "-a") then do; control_args.print_all = "1"b; return; end; if arg_ptr -> based_argument = "-host" then do; control_args.required_host = "1"b; do arg_indx = arg_indx + 1 by 1; call cu_$arg_ptr_rel (arg_indx, arg_ptr, arg_length, err_code, p_arg_list_ptr); if err_code ^= 0 then do; arg_indx = arg_indx - 1; return; end; if substr (arg_ptr -> based_argument, 1, 1) = "-" then do; /* argument starts with "-", is new control arg */ arg_indx = arg_indx - 1; return; end; call host_id_$check_id (arg_ptr -> based_argument, "0"b, required_host_number, (""b), err_code); if err_code ^= 0 then do; call com_err_ (err_code, "print_ncp_errors", arg_ptr -> based_argument); goto return_to_caller; end; substr (control_args.report_host, required_host_number + 1, 1) = "1"b; end; end; if (arg_ptr -> based_argument = "-history") | (arg_ptr -> based_argument = "-ht") then do; control_args.history = "1"b; return; end; if (arg_ptr -> based_argument = "-noheader") | (arg_ptr -> based_argument = "-nhe") then do; control_args.print_header = "0"b; return; end; if (arg_ptr -> based_argument = "-long") | (arg_ptr -> based_argument = "-lg") then do; control_args.format = "11"b; return; end; if (arg_ptr -> based_argument = "-brief") | (arg_ptr -> based_argument = "-bf") then do; control_args.format = "01"b; return; end; if arg_ptr -> based_argument = "-full" then do; control_args.format = "10"b; return; end; call com_err_ (error_table_$badopt, "print_ncp_errors", arg_ptr -> based_argument); goto return_to_caller; end; /* end process_control_arg */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end process_options */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ userids_match: procedure (p_user_id) returns (bit (1) aligned); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_user_id character (32) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (name_length fixed binary (24), (person_name, project_name) character (32)) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (admin_person = "") & (admin_project = "") then return ("1"b); name_length = index (p_user_id, "."); if name_length = 0 then do; person_name = p_user_id; project_name = ""; end; else do; person_name = substr (p_user_id, 1, name_length - 1); project_name = substr (p_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; /* end userids_match */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end print_ncp_errors */ end;  print_ncp_status.pl1 09/23/77 1033.7rew 09/22/77 1723.9 81729 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ print_ncp_status: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (num_args fixed binary (17), err_code fixed binary (35), seg_ptr pointer) automatic; declare abort_command variable entry options (variable) initial (abort_command_invocation) automatic; declare 1 options aligned automatic, 2 long_format bit (1); /* * * * * INTERNAL STATIC DECLARATIONS * * * * */ /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare PROG character (32) initial ("print_ncp_status") internal static options (constant); /* * * * BASED & TEMPLATE DECLARATIONS * * * * * */ /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare (error_table_$badopt, error_table_$namedup, error_table_$noarg, error_table_$segknown) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare com_err_ constant entry options (variable), cu_$arg_count constant entry (fixed bin (17)), cu_$arg_list_ptr constant entry () returns (ptr), cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr), cu_$gen_call constant entry (entry, ptr), date_time_ constant entry (fixed bin (71), char (*)), get_pdir_ constant entry () returns (char (168) aligned), hcs_$delentry_seg constant entry (ptr, fixed bin (35)), hcs_$make_seg constant entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), ioa_ constant entry options (variable), netp_$ncp_priv_status constant entry (fixed bin (12), fixed bin (18), ptr, fixed bin (19), fixed bin (35)); declare (binary, null, unspec) builtin; /* * * * * STACK REFERENCES * * * * * * * * * * */ declare cleanup condition; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include ncp_data_dcls; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ err_code = 0; call cu_$arg_count (num_args); if num_args < 0 then do; call ioa_ ("Usage is:^/^10x^a -ctl_args-", PROG); return; end; call process_options (cu_$arg_list_ptr ()); seg_ptr = null (); on cleanup call cleanup_after_command (); call hcs_$make_seg (get_pdir_ (), "print_ncp_status_temp_", "", 01011b, seg_ptr, err_code); if (err_code ^= 0) & (err_code ^= error_table_$segknown) & (err_code ^= error_table_$namedup) then call abort_command (err_code, PROG, "Unable to create temporary segment."); call netp_$ncp_priv_status (1, 0, seg_ptr, 65536, err_code); if err_code ^= 0 then call abort_command (err_code, PROG, "Attempting to copy out ncp data."); call perform_function (seg_ptr); call cleanup_after_command (); return_to_caller: return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ perform_function: procedure (p_data_ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_data_ptr pointer parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare date_time_string character (24) automatic; /* * * * * DEFINED REFERENCES * * * * * * * * * */ declare 1 ncp_data aligned like ncp_dt defined (p_data_ptr -> ncp_dt); /* * * * * * * * * * * * * * * * * * * * * * * * */ call ioa_ ("NCP state is: ^d.", ncp_data.ncp_up); call ioa_ ("Local host number is ^d.", ncp_data.host_id); call ioa_ ("IMP state is ^a.", ncp_data.imp_state); if ncp_data.imp_special_message ^= ""b then call ioa_ ("IMP Special Message: ^o", binary (ncp_data.imp_special_message, 32)); if ncp_data.ncp_up ^= 2 then call ioa_ ("NCP state change reason is ^a.", ncp_data.state_change_reason); if ^ options.long_format then return; call ioa_ ("Network Daemon process: ^w", ncp_data.ncp_procid); call ioa_ ("Network Daemon event channel: ^24.3b", unspec (ncp_data.ncp_ev_chan)); call ioa_ ("Connect Access segment is ^a>^a.", ncp_data.access_dirname, ncp_data.access_ename); call date_time_ (ncp_data.time_imp_state_changed, date_time_string); call ioa_ ("Number IMP state changes: ^d.", ncp_data.imp_state_change_count); call ioa_ ("IMP last changed state at ^a.", date_time_string); call ioa_ ("Number NCP state changes: ^d.", ncp_data.ncp_state_changes); call date_time_ (ncp_data.time_ncp_state_changed, date_time_string); call ioa_ ("NCP last changed state at ^a.", date_time_string); call ioa_ ("Max entries used are: ^d RFCs, ^d sockets, ^d processes.", ncp_data.rtbl_gent, ncp_data.stbl_gent, ncp_data.ptbl_gent); return; end; /* end perform_function */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_options: procedure (P_arg_list_ptr); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_arg_list_ptr pointer parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (arg_indx fixed binary (17), arg_length fixed binary (24), arg_ptr pointer) automatic; /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare based_argument character (arg_length) based; /* * * * * * * * * * * * * * * * * * * * * * * * */ options.long_format = "0"b; do arg_indx = 1 repeat (arg_indx + 1) while (got_argument (arg_indx)); call process_control_argument (arg_ptr -> based_argument); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ got_argument: procedure (P_arg) returns (bit (1)); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_arg fixed binary (17) /* index of the argument which we are to address */ parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$arg_ptr_rel (P_arg, arg_ptr, arg_length, err_code, P_arg_list_ptr); if err_code = 0 then return ("1"b); if err_code = error_table_$noarg then return ("0"b); call abort_command (err_code, (PROG), "Attempting to get argument #^d.", P_arg); end; /* end got_argument */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_control_argument: procedure (p_control_arg); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare p_control_arg character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if (p_control_arg = "-long") | (p_control_arg = "-lg") then do; options.long_format = "1"b; return; end; if (p_control_arg = "-brief") | (p_control_arg = "-bf") then do; options.long_format = "0"b; return; end; call abort_command (error_table_$badopt, (PROG), p_control_arg); end; /* end process_control_argument */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end process_options */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup_after_command: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ if seg_ptr ^= null () then call hcs_$delentry_seg (seg_ptr, (0)); return; end; /* end cleanup_after_command */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ abort_command_invocation: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$gen_call (com_err_, cu_$arg_list_ptr ()); call cleanup_after_command (); goto return_to_caller; end; /* end abort_command_invocation */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end print_ncp_status */ end;  test_net_connections.pl1 09/23/77 1033.7rew 09/22/77 1723.9 209115 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ test_net_connections: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ((icp_pin, server_pin, user_pin) fixed binary (8), local_host fixed binary (16), try fixed binary (17), arg_count fixed binary (17), temp_value fixed binary (17), (num_attempts, timeout_period) fixed binary (17), sleep_period fixed binary (17), userid fixed binary (24), arg_length fixed binary (24), icp_socket fixed binary (32), err_code fixed binary (35), (icp_channel, server_channel, user_channel) fixed binary (71), ipc_data (4) fixed binary (71), (should_dump, should_trace) bit (1), comment_string character (256) varying, arg_ptr pointer) automatic; /* * * * * TEXT SECTION REFERENCES * * * * * * * * */ declare (test_message (0 : 3) bit (8) initial ("00001111"b, "11110000"b, "01010101"b, "10101010"b), PROG character (32) initial ("test_net_connections")) internal static options (constant); /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare based_argument character (arg_length) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare (error_table_$badopt, error_table_$net_icp_not_concluded, error_table_$no_device) fixed binary (35) external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare clock_ constant entry () returns (fixed bin (71)), com_err_ constant entry options (variable), cu_$arg_count constant entry () returns (fixed bin (17)), cu_$arg_list_ptr constant entry () returns (ptr), cu_$arg_ptr_rel constant entry (fixed bin (17), ptr, fixed bin (24), fixed bin (35), ptr), cv_dec_check_ constant entry (char (*), fixed bin (35)) returns (fixed bin (35)), dump_ncp_databases constant entry options (variable), get_process_id_ constant entry () returns (bit (36) aligned), hcs_$wakeup constant entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)), ioa_ constant entry options (variable), ioa_$rsnnl constant entry options (variable), ipc_$block constant entry (ptr, ptr, fixed bin (35)), ipc_$create_ev_chn constant entry (fixed bin (71), fixed bin (35)), ncp_$close_connection constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$detach_socket constant entry (bit (36), fixed bin (35)), ncp_$local_host_number constant entry (fixed bin (16), fixed bin (35)), ncp_$get_socket_state constant entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$get_userid constant entry (fixed bin (24), fixed bin (35)), ncp_$read_data constant entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), ncp_$write_data constant entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), net_$ncp_trace_comment constant entry (char (*)), net_connect_$abort_connection constant entry (fixed bin (8), fixed bin (35)), net_connect_$complete_connection constant entry (fixed bin (8), fixed bin (71), fixed bin (71), fixed bin (16), fixed bin (32), bit (36), bit (36), fixed bin (35)), net_connect_$open_connection constant entry (fixed bin (8), fixed bin (17), fixed bin (16), fixed bin (32), bit (2), fixed bin (17), fixed bin (71), fixed bin (35)), net_pin_manager_$allocate_pins constant entry (fixed bin (8), fixed bin (8), fixed bin (35)), net_pin_manager_$free_pins constant entry (fixed bin (8), fixed bin (8), fixed bin (35)), net_icp_server_$initiate_service constant entry (fixed bin (8), entry (ptr, fixed bin (16), fixed bin (32), fixed bin (32), fixed bin (35)), ptr, fixed bin (17), fixed bin (71), fixed bin (35)), net_icp_server_$terminate_service constant entry (fixed bin (8), fixed bin (35)), timer_manager_$sleep constant entry (fixed bin (71), bit (2)); declare (addr, binary, bit, dimension, mod, null) builtin; /* * * * * STACK REFERENCES * * * * * * * * * * */ declare cleanup condition; /* * * * * INCLUDE FILES * * * * * * * * * * * * */ % include net_event_template; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ arg_count = cu_$arg_count (); if arg_count = 0 then do; call ioa_ ("Usage is:^/^10x^a -ctl_args-", (PROG)); call ioa_ ("Known control arguments are:"); call ioa_ ("^10x-sleep -- specifies time to sleep between tests"); call ioa_ ("^10x-repeat -- specifies number of connection attempts"); call ioa_ ("^10x-dump -- specifies that a dump is to be taken on failure."); call ioa_ ("^10x-trace -- specifies that trace calls should be made to the NCP"); return; end; call process_options (cu_$arg_list_ptr (), arg_count); call ncp_$get_userid (userid, err_code); if err_code ^= 0 then call abort_test ("Unable to get userid"); call net_pin_manager_$allocate_pins (2, icp_pin, err_code); if err_code ^= 0 then call abort_test ("Unable to get pins for icp server socket."); call ioa_$rsnnl ("ICP pin is ^d.", comment_string, (0), icp_pin + 1); call ioa_ ("^a", comment_string); if should_trace then call net_$ncp_trace_comment ((comment_string)); call ncp_$local_host_number (local_host, err_code); if err_code ^= 0 then call abort_test ("Unable to determine local host number"); icp_socket = userid * 256 + icp_pin + 1; call ipc_$create_ev_chn (server_channel, err_code); if err_code ^= 0 then call abort_test ("Unable to create event channel for icp server."); call ipc_$create_ev_chn (user_channel, err_code); if err_code ^= 0 then call abort_test ("Unable to create event channel for user side."); user_pin = 0; server_pin = 0; on cleanup begin; call net_connect_$abort_connection (user_pin, (0)); call net_connect_$abort_connection (server_pin, (0)); call net_icp_server_$terminate_service (icp_pin + 1, (0)); call net_pin_manager_$free_pins (4, user_pin, (0)); call net_pin_manager_$free_pins (2, server_pin, (0)); call net_pin_manager_$free_pins (2, icp_pin, (0)); end; call net_icp_server_$initiate_service (icp_pin + 1, find_socket, null (), timeout_period, 0, err_code); if err_code ^= 0 then call abort_test ("Unable to initiate server icp."); do try = 1 by 1 to num_attempts; if mod (try, 10) = 0 then call ioa_ ("Test #^d.", try); call net_pin_manager_$allocate_pins (4, user_pin, err_code); if err_code ^= 0 then call abort_test ("Unable to allocate user side pins"); call attempt_connection (user_pin); call net_pin_manager_$free_pins (4, user_pin, (0)); if sleep_period ^= 0 then call timer_manager_$sleep ((sleep_period), "11"b); /* wait for sleep_period secs */ end; call net_icp_server_$terminate_service (icp_pin + 1, (0)); call net_pin_manager_$free_pins (2, icp_pin + 1, (0)); comment_string = "Test completed."; call ioa_ ("^a", comment_string); if should_trace then call net_$ncp_trace_comment ((comment_string)); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ return_to_caller: return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ find_socket: procedure (p_data_ptr, p_foreign_host, p_foreign_socket, p_local_socket, p_error_code); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (p_error_code fixed binary (35), p_foreign_host fixed binary (16), p_local_socket fixed binary (32), p_foreign_socket fixed binary (32), p_data_ptr pointer) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if should_trace then call net_$ncp_trace_comment ("find socket called"); call net_pin_manager_$allocate_pins (2, server_pin, p_error_code); if p_error_code ^= 0 then do; call com_err_ (p_error_code, PROG, "Unable to allocate server pins"); if should_trace then call net_$ncp_trace_comment ("unable to allocate server pins"); return; end; call net_connect_$open_connection (server_pin, 13, p_foreign_host, p_foreign_socket + 2, "11"b, timeout_period, server_channel, p_error_code); if p_error_code ^= 0 then do; call com_err_ (p_error_code, PROG, "Unable to open server connection."); if should_trace then call net_$ncp_trace_comment ("Unable to open server connection."); return; end; p_local_socket = userid * 256 + server_pin; if should_trace then call net_$ncp_trace_comment ("find socket successful"); p_error_code = 0; return; end; /* end find_socket */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ attempt_connection: procedure (P_pin); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_pin fixed binary (8) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (state fixed binary (6), nelemt fixed binary (24), pause_period fixed binary (71), /* time to pause at various points */ timeout_clock fixed binary (71), first_loop bit (1), /* often used in do while loops to initialize */ (U_rcvd, S_rcvd) bit (1), discard_area (0 : 200) bit (8), ncp_indx bit (36), (SR, SW, UR, UW) bit (36)) automatic; declare 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 padding bit (36) aligned, 2 channel fixed binary (71); declare 1 event_message aligned automatic like event_message_template; /* * * * * * * * * * * * * * * * * * * * * * * * */ if should_trace then do; call ioa_$rsnnl ("Begin test ^d, pin = ^d", comment_string, (0), try, P_pin); call net_$ncp_trace_comment ((comment_string)); end; call net_connect_$open_connection (P_pin, 11, local_host, icp_socket, "11"b, timeout_period, user_channel, err_code); if err_code ^= 0 then call abort_connection ("Unable to initiate user side of connection"); wait_list.channel = user_channel; err_code = error_table_$net_icp_not_concluded; do while (err_code = error_table_$net_icp_not_concluded); call ipc_$block (addr (wait_list), addr (event_message), err_code); if err_code ^= 0 then call abort_connection ("ipc block for user side returned error code"); call net_connect_$complete_connection (P_pin, 0, 0, (0), (0), UR, UW, err_code); end; if err_code ^= 0 then call abort_connection ("Unable to complete connection for user side"); wait_list.channel = server_channel; err_code = error_table_$net_icp_not_concluded; do while (err_code = error_table_$net_icp_not_concluded); call ipc_$block (addr (wait_list), addr (event_message), err_code); if err_code ^= 0 then call abort_connection ("ipc block for server side returned error code"); call net_connect_$complete_connection (server_pin, 0, 0, (0), (0), SR, SW, err_code); end; if err_code ^= 0 then call abort_connection ("Unable to complete connection for server side"); do ncp_indx = UW, SW; call ncp_$write_data (ncp_indx, addr (test_message), dimension (test_message, 1), nelemt, state, err_code); if nelemt ^= dimension (test_message, 1) then call abort_connection ("NCP wouldnt accept test message"); if state ^= 6 then call abort_connection ("Socket wasn't in state 6"); if err_code ^= 0 then call abort_connection ("non zero error code returned from ncp_write"); end; timeout_clock = clock_ () + timeout_period * 1000000; U_rcvd = "0"b; S_rcvd = "0"b; do first_loop = "1"b repeat ("0"b) while (^ U_rcvd | ^ S_rcvd); if ^ first_loop then do; if clock_ () > timeout_clock then call abort_connection ("Timeout waiting for data"); call timer_manager_$sleep (100000, "10"b); /* wait for 100 msecs */ end; if ^ U_rcvd then do; call ncp_$read_data (UR, addr (discard_area), dimension (discard_area, 1), nelemt, state, err_code); if err_code ^= 0 then call abort_connection ("User side read got error code"); if nelemt ^= 0 then U_rcvd = "1"b; end; if ^ S_rcvd then do; call ncp_$read_data (SR, addr (discard_area), dimension (discard_area, 1), nelemt, state, err_code); if err_code ^= 0 then call abort_connection ("Server side read got error code"); if nelemt ^= 0 then S_rcvd = "1"b; end; end; do ncp_indx = UR, UW; call ncp_$close_connection (ncp_indx, state, err_code); end; do first_loop = "1"b repeat ("0"b) while (UR | UW | SR | SW); if ^ first_loop then do; if clock_ () > timeout_clock then call abort_connection ("Timeout while waiting for connection to close"); call timer_manager_$sleep (100000, "10"b); /* wait for 100msecs */ end; call wait_for_close (UR); call wait_for_close (UW); call wait_for_close (SR); call wait_for_close (SW); end; call net_pin_manager_$free_pins (2, server_pin, (0)); call ioa_$rsnnl ("Test succeeded: ^d", comment_string, (0), try); if should_trace then call net_$ncp_trace_comment ((comment_string)); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ return_to_caller_of_test: return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ wait_for_close: procedure (P_ncp_indx); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_ncp_indx bit (36) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if P_ncp_indx = ""b then return; call ncp_$get_socket_state (P_ncp_indx, state, err_code); if err_code ^= 0 then call abort_connection ("non-zero error code while waiting for close"); if state ^= 1 then return; call ncp_$detach_socket (P_ncp_indx, (0)); P_ncp_indx = ""b; return; end; /* end wait_for_close */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ abort_connection: procedure (P_complaint); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_complaint character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call ioa_$rsnnl ("Test ^d failed: ^a", comment_string, (0), try, P_complaint); if should_trace then call net_$ncp_trace_comment ((comment_string)); call com_err_ (err_code, (PROG), comment_string); if should_dump then call dump_ncp_databases (); goto return_to_caller_of_test; end; /* end abort_connection */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end attempt_connection */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ abort_test: procedure (P_complaint); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_complaint character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if should_trace then call net_$ncp_trace_comment (P_complaint); call com_err_ (err_code, (PROG), P_complaint); goto return_to_caller; end; /* end abort_test */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_options: procedure (P_arg_list_ptr, P_arg_count); /* * * * * PARAMETER DECLARATIONS * * * * * * */ declare (P_arg_count fixed binary (17), P_arg_list_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (arg_indx fixed binary (17), arg_length fixed binary (24), arg_ptr pointer) automatic; /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare based_argument character (arg_length) based; /* * * * * * * * * * * * * * * * * * * * * * * */ /* Following are the default values for options */ num_attempts = 1000; timeout_period = 15; sleep_period = 0; should_dump = "0"b; should_trace = "0"b; do arg_indx = 1 by 1 to P_arg_count; call get_argument ("Referencing arguments to procedure."); call process_control_argument (arg_ptr -> based_argument); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_argument: procedure (P_complaint_explanation); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_complaint_explanation character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$arg_ptr_rel (arg_indx, arg_ptr, arg_length, err_code, P_arg_list_ptr); if err_code ^= 0 then do; call com_err_ (err_code, (PROG), P_complaint_explanation); goto return_to_caller; end; return; end; /* end get_argument */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_control_argument: procedure (P_control_argument); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare P_control_argument character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * */ if P_control_argument = "-repeat" then do; arg_indx = arg_indx + 1; call get_argument ("The -repeat argument requires a repeat count."); num_attempts = cv_dec_check_ (arg_ptr -> based_argument, err_code); if err_code ^= 0 then do; call com_err_ (0, (PROG), "Invalid number for repeat attempts: ^a", arg_ptr -> based_argument); goto return_to_caller; end; return; end; if P_control_argument = "-sleep" then do; arg_indx = arg_indx + 1; call get_argument ("The -sleep argument requires a number of seconds."); sleep_period = cv_dec_check_ (arg_ptr -> based_argument, err_code); if err_code ^= 0 then do; call com_err_ (0, (PROG), "Invalid number of seconds to sleep: ^a", arg_ptr -> based_argument); goto return_to_caller; end; return; end; if arg_ptr -> based_argument = "-timeout" then do; arg_indx = arg_indx + 1; call get_argument ("Getting timeout period for -timeout control argument."); timeout_period = cv_dec_check_ (arg_ptr -> based_argument, err_code); if err_code ^= 0 then do; call com_err_ (0, (PROG), "Invalid number of seconds to wait for response: ^a", arg_ptr -> based_argument); goto return_to_caller; end; return; end; if P_control_argument = "-dump" then do; should_dump = "1"b; return; end; if P_control_argument = "-trace" then do; should_trace = "1"b; return; end; call com_err_ (error_table_$badopt, (PROG), P_control_argument); goto return_to_caller; end; /* end process_control_argument */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* end process_options */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* end test_net_connections */ 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