Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / defdata / telwicat.src < prev next >

Wrap

Text File | 1988-05-03 | 213.4 KB | 5,012 lines

--:::::::::::::: --akeybdpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01203-100(-) -- E-Systems, Inc. August 07, 1985 -- -- akeybdpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- WITH SYSTEM ; PACKAGE nvt_keyboard_input_processing IS SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; SUBTYPE character_type IS bit_count_8_type ; FUNCTION there_is_input_from_the_NVT_keyboard RETURN BOOLEAN ; PROCEDURE get_a_character (char : OUT character_type ; the_char_is_a_control_function : OUT BOOLEAN) ; PROCEDURE process_standard_control_function_from_keyboard (char : IN character_type) ; PROCEDURE process_partial_command (char : IN character_type) ; PROCEDURE put_character_in_data_buffer (char : IN character_type) ; PROCEDURE send_data_buffer_to_transport_level ; END nvt_keyboard_input_processing ; WITH virtual_transport_level ; WITH virtual_terminal ; WITH option_negotiation ; WITH user_data ; USE user_data ; WITH debug_io ; PACKAGE BODY nvt_keyboard_input_processing IS SUBTYPE bit_count_32_type IS LONG_INTEGER ; SUBTYPE bit_count_16_type IS INTEGER ; FUNCTION there_is_input_from_the_NVT_keyboard RETURN BOOLEAN IS BEGIN RETURN virtual_terminal.there_are_characters_in_keyboard_buffer (user_data.user_control_block.port) ; END there_is_input_from_the_NVT_keyboard ; PROCEDURE get_a_character (char : OUT character_type ; the_char_is_a_control_function : OUT BOOLEAN) IS temp_char : character_type ; temp_the_char_is_a_control_function : BOOLEAN ; PROCEDURE determine_if (the_char_is_a_control_function : OUT BOOLEAN ; char : IN bit_count_8_type) IS BEGIN the_char_is_a_control_function := FALSE ; END determine_if ; BEGIN virtual_terminal.get_next_character_from_keyboard_buffer (user_data.user_control_block.port, temp_char) ; determine_if(temp_the_char_is_a_control_function, temp_char) ; char := temp_char ; the_char_is_a_control_function := temp_the_char_is_a_control_function ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_a_char") ; RAISE ; END get_a_character ; PROCEDURE process_standard_control_function_from_keyboard (char : IN character_type) IS IAC : bit_count_8_type := 255 ; no_partial_command : user_data.command_state_type ; urgent : BOOLEAN := TRUE ; command_bytes : virtual_transport_level.info_output_type(1..2) ; BEGIN no_partial_command := user_data.no_partial_command ; CASE char IS WHEN 242..249 => IF user_data.user_control_block.command_state = no_partial_command THEN put_character_in_data_buffer(IAC) ; put_character_in_data_buffer(char) ; ELSE process_partial_command(char) ; END IF ; WHEN OTHERS => NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.proc_std_cont_f") ; RAISE ; END process_standard_control_function_from_keyboard ; PROCEDURE process_partial_command (char : IN character_type) IS PROCEDURE add_the_character_to_the_partial_command_buffer (char : IN character_type) IS command_buffer : user_data.out_string_type ; SUBTYPE length_type IS bit_count_16_type RANGE 0..user_data.max_out_string ; length : length_type ; no_partial_command : user_data.command_state_type ; slash : CONSTANT bit_count_8_type := 16#2F# ; E : CONSTANT bit_count_8_type := 16#45# ; L : CONSTANT bit_count_8_type := 16#4C# ; B : CONSTANT bit_count_8_type := 16#42# ; A : CONSTANT bit_count_8_type := 16#41# ; D : CONSTANT bit_count_8_type := 16#44# ; bell : CONSTANT bit_count_8_type := 16#07# ; cr : CONSTANT bit_count_8_type := 16#0D# ; lf : CONSTANT bit_count_8_type := 16#0A# ; not_control_char : BOOLEAN := FALSE ; BEGIN no_partial_command := user_data.no_partial_command ; CASE char IS WHEN 247 | 248 => IF user_data.there_is_data_in_command_buffer THEN user_data.get_command_buffer(command_buffer, length) ; IF char = 247 THEN FOR index IN 1..length-1 LOOP user_data.put_char_in_command_buffer(command_buffer(index)) ; END LOOP ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, slash) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, command_buffer(length)) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, slash) ; length := length - 1 ; ELSE virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, slash) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, E) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, L) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, slash) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, cr) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, lf) ; length := 0 ; END IF ; IF length = 0 THEN user_data.user_control_block.command_state := no_partial_command ; END IF ; END IF ; WHEN 242 | 243 | 244 | 245 | 246 | 249 => user_data.user_control_block.command_state := no_partial_command ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, B) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, A) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, D) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, bell) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, cr) ; virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, lf) ; WHEN OTHERS => user_data.put_char_in_command_buffer(char) ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.add_char_to_pcb") ; RAISE ; END add_the_character_to_the_partial_command_buffer ; PROCEDURE parse_command_buffer_for_semantics_and_make_call_to_presentation_level IS command : user_data.out_string_type ; SUBTYPE length_type IS bit_count_16_type RANGE 1..user_data.max_cmd_length ; length : length_type ; command_string : STRING (1..user_data.max_cmd_length) ; successful : BOOLEAN ; TYPE command_type IS (open_command, close_command, status_command, reset_command, echo_local_command, echo_remote_command, suppress_ga_local_command, suppress_ga_remote_command, send_abort_output_command, send_are_you_there_command, send_break_command, send_erase_character_command, send_erase_line_command, send_interrupt_process_command, send_sync_command, quit_echo_local_command, quit_echo_remote_command, quit_suppress_ga_local_command, quit_suppress_ga_remote_command, bad_command) ; type_of_command : command_type ; not_urgent : BOOLEAN := FALSE ; urgent : BOOLEAN := TRUE ; command_bytes : virtual_transport_level.info_output_type(1..2) ; not_control_characters : BOOLEAN := FALSE ; TYPE bytes_type IS ARRAY (bit_count_16_type RANGE <>) OF bit_count_8_type ; address_length : bit_count_16_type ; network_number : bit_count_16_type ; host_number : bit_count_16_type ; logical_host_number : bit_count_16_type ; imp_number : bit_count_16_type ; port_number : bit_count_16_type ; PROCEDURE determine_command_type (command_string_in : IN STRING ; length : IN bit_count_16_type ; type_of_command : OUT command_type) IS command_string : STRING(1..length + 3) ; ok : BOOLEAN ; PROCEDURE strip_off_extra_characters (item : IN OUT STRING ; string_length : IN OUT bit_count_16_type) IS kept_pos : bit_count_16_type RANGE 1..string_length + 3 := 1 ; kept_buffer : STRING (1..string_length + 3) ; store_char : BOOLEAN := FALSE ; adr_start_pos : bit_count_16_type RANGE 1..string_length ; BEGIN IF item(2) = 'O' OR item(2) = 'o' THEN kept_buffer(1..4) :="O " ; kept_pos := 4 ; FOR index IN 3..string_length LOOP IF item(index) = ' ' THEN adr_start_pos := index + 1 ; EXIT ; END IF ; END LOOP ; FOR index IN adr_start_pos..string_length LOOP kept_pos := kept_pos + 1 ; kept_buffer(kept_pos) := item(index) ; END LOOP ; string_length := kept_pos ; ELSE kept_buffer(1) := item(2) ; FOR item_pos IN 3..string_length LOOP IF item(item_pos) = ' ' THEN store_char := TRUE ; ELSE IF store_char THEN kept_pos := kept_pos + 1 ; kept_buffer(kept_pos) := item(item_pos) ; store_char := FALSE ; END IF ; END IF ; END LOOP ; FOR pad_pos IN kept_pos+1..4 LOOP kept_pos := kept_pos + 1 ; kept_buffer(pad_pos) := ' ' ; END LOOP ; string_length := 0 ; END IF ; item(1..kept_pos) := kept_buffer(1..kept_pos) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.strip_ex") ; RAISE ; END strip_off_extra_characters ; PROCEDURE process_open_command_parameters IS good_number : BOOLEAN ; PROCEDURE strip_command_to_address (command_string : IN OUT STRING ; address_length : IN OUT bit_count_16_type) IS SUBTYPE string_position_type IS bit_count_16_type RANGE 0..bit_count_16_type(user_data.max_cmd_length) ; com_pos : string_position_type ; com_buf : STRING (1..user_data.max_cmd_length) ; buf_pos : string_position_type := 0 ; BEGIN FOR com_pos IN 2..address_length LOOP IF command_string(com_pos) /= ' ' THEN buf_pos := buf_pos + 1 ; com_buf(buf_pos) := command_string(com_pos) ; END IF ; END LOOP ; command_string(1..buf_pos) := com_buf(1..buf_pos) ; address_length := buf_pos ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.strip_addr") ; RAISE ; END strip_command_to_address ; PROCEDURE convert_string_to_integer (input_string : IN STRING ; integer_value : OUT bit_count_16_type ; status : OUT BOOLEAN) IS next_value : bit_count_16_type := 0 ; power_of_ten : bit_count_16_type := 1 ; character_offset : bit_count_16_type := CHARACTER'POS('0') ; temp_integer_value : bit_count_16_type := 0 ; temp_status : BOOLEAN := TRUE ; BEGIN FOR index IN REVERSE INPUT_STRING'RANGE LOOP IF (input_string(index)<'0') OR (input_string(index)>'9') THEN temp_status := FALSE ; EXIT ; END IF ; IF CHARACTER'POS(input_string(index))-character_offset = 0 THEN NULL ; ELSIF power_of_ten > ((bit_count_16_type'LAST - temp_integer_value) / (CHARACTER'POS(input_string(index)) - character_offset)) THEN temp_status := FALSE ; EXIT ; ELSE temp_integer_value := temp_integer_value + (CHARACTER'POS(input_string(index)) - character_offset) * power_of_ten ; END IF ; power_of_ten := power_of_ten * 10 ; END LOOP ; integer_value := temp_integer_value ; status := temp_status ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.conv_s_i") ; RAISE ; END convert_string_to_integer ; PROCEDURE get_port_number (address : IN STRING ; length : IN OUT bit_count_16_type ; status_ok : OUT BOOLEAN) IS BEGIN port_number := 23 ; status_ok := TRUE ; FOR index IN REVERSE 1..length LOOP IF address(index) = ';' THEN convert_string_to_integer(address(index+1..length), port_number, status_ok) ; length := index - 1 ; EXIT ; END IF ; END LOOP ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_port") ; RAISE ; END get_port_number ; PROCEDURE get_next_number (address : IN STRING ; length : IN OUT bit_count_16_type ; number : OUT bit_count_16_type ; ok : OUT BOOLEAN) IS temp_number : bit_count_16_type ; temp_ok : BOOLEAN ; SUBTYPE string_position_type IS bit_count_16_type RANGE 0..user_data.max_cmd_length ; buf_pos : bit_count_16_type := 0 ; num_buf : STRING (1..user_data.max_cmd_length) ; delimiter : CHARACTER := '.' ; delimiter_found : bit_count_16_type RANGE 0..1 := 0 ; num_digits : bit_count_16_type RANGE 0..5 := 0 ; BEGIN temp_ok := TRUE ; FOR add_pos IN REVERSE 1..length LOOP IF address(add_pos) = delimiter THEN delimiter_found := 1 ; EXIT ; ELSE num_digits := num_digits + 1 ; END IF ; END LOOP ; FOR add_pos IN length-num_digits+1..length LOOP buf_pos := buf_pos + 1 ; num_buf(buf_pos) := address(add_pos) ; END LOOP ; IF num_digits /= 0 THEN convert_string_to_integer(num_buf(1..num_digits), temp_number, temp_ok) ; ELSE temp_number := 0 ; END IF ; length := length - num_digits - delimiter_found ; number := temp_number ; ok := temp_ok ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_num") ; RAISE ; END get_next_number ; PROCEDURE get_imp_number (address : IN STRING ; length : IN OUT bit_count_16_type ; status_ok : OUT BOOLEAN) IS temp_status_ok : BOOLEAN ; BEGIN get_next_number(address, length, imp_number, temp_status_ok) ; IF imp_number = 0 THEN temp_status_ok := FALSE ; END IF ; status_ok := temp_status_ok ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_imp") ; RAISE ; END get_imp_number ; PROCEDURE get_logical_host_number (address : IN OUT STRING ; length : IN OUT bit_count_16_type ; status_ok : OUT BOOLEAN) IS temp_status_ok : BOOLEAN ; BEGIN get_next_number (address, length, logical_host_number, temp_status_ok) ; status_ok := temp_status_ok ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_lhost") ; RAISE ; END get_logical_host_number ; PROCEDURE get_host_number (address : IN OUT STRING ; length : IN OUT bit_count_16_type ; status_ok : OUT BOOLEAN) IS temp_status_ok : BOOLEAN ; BEGIN get_next_number(address, length, host_number, temp_status_ok) ; status_ok := temp_status_ok ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_host") ; RAISE ; END get_host_number ; PROCEDURE get_network_number (address : IN OUT STRING ; length : IN OUT bit_count_16_type ; status_ok : OUT BOOLEAN) IS temp_status_ok : BOOLEAN ; BEGIN get_next_number(address, length, network_number, temp_status_ok) ; IF network_number = 0 THEN network_number := 10 ; END IF ; status_ok := temp_status_ok ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_net") ; RAISE ; END get_network_number ; BEGIN strip_command_to_address(command_string(1..address_length), address_length) ; get_port_number(command_string, address_length, ok) ; IF ok THEN get_imp_number(command_string(1..address_length), address_length, ok) ; IF ok THEN get_logical_host_number(command_string(1..address_length), address_length, ok) ; IF ok THEN get_host_number(command_string, address_length, ok) ; IF ok THEN get_network_number(command_string, address_length, ok) ; END IF ; END IF ; END IF ; END IF ; IF NOT (ok) THEN type_of_command := bad_command ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.pr_open_cmd_par") ; RAISE ; END process_open_command_parameters ; BEGIN command_string(1..length) := command_string_in(1..length) ; address_length := length ; strip_off_extra_characters(command_string(1..length+3), address_length) ; IF command_string(1..4) = "O " THEN type_of_command := open_command ; process_open_command_parameters ; ELSIF command_string(1..4) = "C " OR command_string(1..4)="c " THEN type_of_command := close_command ; ELSIF command_string(1..4) = "S " OR command_string(1..4)="s " THEN type_of_command := status_command ; ELSIF command_string(1..4) = "R " OR command_string(1..4)="r " THEN type_of_command := reset_command ; ELSIF command_string(1..4) = "EL " OR command_string(1..4)="el " THEN type_of_command := echo_local_command ; ELSIF command_string(1..4) = "ER " OR command_string(1..4)="er " THEN type_of_command := echo_remote_command ; ELSIF command_string(1..4) = "QEL " OR command_string(1..4)="qel " THEN type_of_command := quit_echo_local_command ; ELSIF command_string(1..4) = "QER " OR command_string(1..4)="qer " THEN type_of_command := quit_echo_remote_command ; ELSIF command_string(1..4) = "SGL " OR command_string(1..4)="sgl " THEN type_of_command := suppress_ga_local_command ; ELSIF command_string(1..4) = "SGR " OR command_string(1..4)="sgr " THEN type_of_command := suppress_ga_remote_command ; ELSIF command_string(1..4) = "QSGL" OR command_string(1..4)="qsgl" THEN type_of_command := quit_suppress_ga_local_command ; ELSIF command_string(1..4) = "QSGR" OR command_string(1..4)="qsgr" THEN type_of_command := quit_suppress_ga_remote_command ; ELSIF command_string(1..4) = "SAO " OR command_string(1..4)="sao " THEN type_of_command := send_abort_output_command ; ELSIF command_string(1..4) = "SAYT" OR command_string(1..4)="sayt" THEN type_of_command := send_are_you_there_command ; ELSIF command_string(1..4) = "SB " OR command_string(1..4)="sb " THEN type_of_command := send_break_command ; ELSIF command_string(1..4) = "SEC " OR command_string(1..4)="sec " THEN type_of_command := send_erase_character_command ; ELSIF command_string(1..4) = "SEL " OR command_string(1..4)="sel " THEN type_of_command := send_erase_line_command ; ELSIF command_string(1..4) = "SIP " OR command_string(1..4)="sip " THEN type_of_command := send_interrupt_process_command ; ELSIF command_string(1..4) = "SS " OR command_string(1..4)="ss " THEN type_of_command := send_sync_command ; ELSE type_of_command := bad_command ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.deter_cmd_type") ; RAISE ; END determine_command_type ; PROCEDURE convert_string_to_byte (item : IN STRING ; bytes : OUT bytes_type) IS BEGIN FOR index IN 1..item'length LOOP bytes(bit_count_16_type(index)) := bit_count_8_type(CHARACTER'POS(item(index))) ; END LOOP ; END convert_string_to_byte ; PROCEDURE convert_user_data_bytes_to_string (bytes : IN user_data.out_string_type ; str : OUT STRING ; length : IN bit_count_16_type ; ok : OUT BOOLEAN) IS BEGIN ok := TRUE ; FOR index IN 1..length LOOP IF bytes(index) > 16#7F# THEN ok := FALSE ; EXIT ; END IF ; str(index) := CHARACTER'VAL(bytes(index)) ; END LOOP ; END convert_user_data_bytes_to_string ; BEGIN user_data.get_command_buffer(command, length) ; convert_user_data_bytes_to_string (command, command_string, length, successful) ; IF successful THEN determine_command_type(command_string, length, type_of_command) ; ELSE type_of_command := bad_command ; END IF ; CASE type_of_command IS WHEN open_command => DECLARE parameter : virtual_transport_level.service_call_parameters_type (virtual_transport_level.TL_open) ; BEGIN parameter.network_number := network_number ; parameter.host_number := host_number ; parameter.logical_host_number := logical_host_number ; parameter.imp_number := imp_number ; parameter.port_number := port_number ; virtual_transport_level.convert_service_call_to_transport_level_syntax (virtual_transport_level.TL_open, parameter) ; END ; WHEN close_command => DECLARE parameter : virtual_transport_level.service_call_parameters_type (virtual_transport_level.TL_close) ; BEGIN virtual_transport_level.convert_service_call_to_transport_level_syntax (virtual_transport_level.TL_close, parameter) ; END ; WHEN status_command => DECLARE parameter : virtual_transport_level.service_call_parameters_type (virtual_transport_level.TL_status) ; BEGIN virtual_transport_level.convert_service_call_to_transport_level_syntax (virtual_transport_level.TL_status, parameter) ; END ; WHEN reset_command => DECLARE parameter : virtual_transport_level.service_call_parameters_type (virtual_transport_level.TL_abort) ; BEGIN virtual_transport_level.convert_service_call_to_transport_level_syntax (virtual_transport_level.TL_abort, parameter) ; END ; WHEN echo_local_command => option_negotiation.request_local_option_enable(user_data.echo) ; WHEN echo_remote_command => option_negotiation.request_remote_option_enable(user_data.echo) ; WHEN quit_echo_local_command => option_negotiation.demand_local_option_disable(user_data.echo) ; WHEN quit_echo_remote_command => option_negotiation.demand_remote_option_disable(user_data.echo) ; WHEN suppress_ga_local_command => option_negotiation.request_local_option_enable(user_data.suppress_ga) ; WHEN suppress_ga_remote_command => option_negotiation.request_remote_option_enable(user_data.suppress_ga) ; WHEN quit_suppress_ga_local_command => option_negotiation.demand_local_option_disable(user_data.suppress_ga) ; WHEN quit_suppress_ga_remote_command => option_negotiation.demand_remote_option_disable(user_data.suppress_ga) ; WHEN send_abort_output_command => command_bytes(1) := 255 ; command_bytes(2) := 245 ; virtual_transport_level.send_data(command_bytes, not_urgent) ; WHEN send_are_you_there_command => command_bytes(1) := 255 ; command_bytes(2) := 246 ; virtual_transport_level.send_data(command_bytes, not_urgent) ; WHEN send_break_command => command_bytes(1) := 255 ; command_bytes(2) := 243 ; virtual_transport_level.send_data(command_bytes, not_urgent) ; WHEN send_erase_character_command => command_bytes(1) := 255 ; command_bytes(2) := 247 ; virtual_transport_level.send_data(command_bytes, not_urgent) ; WHEN send_erase_line_command => command_bytes(1) := 255 ; command_bytes(2) := 248 ; virtual_transport_level.send_data(command_bytes, not_urgent) ; WHEN send_interrupt_process_command => command_bytes(1) := 255 ; command_bytes(2) := 244 ; virtual_transport_level.send_data(command_bytes, not_urgent) ; WHEN send_sync_command => command_bytes(1) := 255 ; command_bytes(2) := 242 ; virtual_transport_level.send_data(command_bytes, urgent) ; WHEN bad_command => DECLARE bad_message : STRING (1..6) ; bytes : bytes_type(1..6) ; not_control_characters : BOOLEAN := FALSE ; BEGIN bad_message(1..3) := "bad" ; bad_message(4) := ascii.bel ; bad_message(5) := ascii.cr ; bad_message(6) := ascii.lf ; convert_string_to_byte(bad_message, bytes) ; FOR index IN 1..6 LOOP virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, bytes(bit_count_16_type(index))) ; END LOOP ; END ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.parse_cmd") ; RAISE ; END parse_command_buffer_for_semantics_and_make_call_to_presentation_level ; FUNCTION char_not_end_of_line RETURN BOOLEAN IS end_of_line : character_type := 16#0D# ; BEGIN RETURN char /= end_of_line ; END char_not_end_of_line ; BEGIN IF char_not_end_of_line THEN add_the_character_to_the_partial_command_buffer(char); ELSE parse_command_buffer_for_semantics_and_make_call_to_presentation_level ; user_data.user_control_block.command_state := user_data.no_partial_command ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.proc_par_cmd") ; RAISE ; END process_partial_command ; PROCEDURE put_character_in_data_buffer (char : IN character_type) IS BEGIN IF user_data.there_is_room_in_data_buffer THEN user_data.put_char_in_data_buffer(char) ; ELSE NULL ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.put_char_dat_buf") ; RAISE ; END put_character_in_data_buffer ; PROCEDURE send_data_buffer_to_transport_level IS apl_buffer : user_data.out_string_type ; ppl_buffer : virtual_transport_level.info_output_type (1..user_data.max_out_string) ; length : bit_count_16_type RANGE 1..user_data.max_out_string ; not_urgent_data : BOOLEAN := FALSE ; BEGIN user_data.user_control_block.ga_received := FALSE ; user_data.get_data_buffer(apl_buffer, length) ; FOR index IN 1..length LOOP ppl_buffer(index) := apl_buffer(index) ; END LOOP ; virtual_transport_level.send_data (ppl_buffer(1..length), not_urgent_data) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.") ; RAISE ; END send_data_buffer_to_transport_level ; BEGIN NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac instantition") ; RAISE ; END nvt_keyboard_input_processing ; --:::::::::::::: --amesspac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01204-100(-) -- E-Systems, Inc. August 07, 1985 -- -- amesspac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : amesspac -- 5/8/85 8:50 AM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 11:15 AM : convert to telesoft for wicat WITH SYSTEM ; -- to gain access to system.byte WITH virtual_transport_level ; WITH virtual_terminal ; WITH user_data ; -- access the port_number PACKAGE message_processing -- specfication ------------------ IS -- ********************** USER SPECIFICATION ******************************** -- -- This package provides data types and subprograms for processing (at -- the APL level) messages from the transport level to TELNET for a -- particular user. A message being information which originated at the -- local transport level, not simply data being relayed from the remote -- TELNET. This information is given higher priority than simple -- data transfer. -- -- **************************************************************************** SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; max_msg_length : CONSTANT bit_count_16_type := virtual_transport_level.max_msg_length ; -- make a deferred constant when supported SUBTYPE message_from_transport_level_type IS virtual_transport_level.message_type ; -- Telelie ADA does not support limited private subtpes ; FUNCTION there_is_a_message_available -- specification ---------------------------- RETURN BOOLEAN ; -- ************************ USER SPECIFICATION **************************** -- -- This function returns true if there is a message available from the -- transport level. ----------------------------------------------------------------------------- PROCEDURE retrieve_message -- specification ---------------- (message : OUT message_from_transport_level_type ; length : OUT bit_count_16_type) ; -- ************************ USER SPECIFICATION **************************** -- -- This procedure gets an entire message from the transport level. ----------------------------------------------------------------------------- PROCEDURE write_message_to_NVT_printer -- specification ---------------------------- (transport_level_message : IN message_from_transport_level_type ; length : IN bit_count_16_type) ; -- ************************ USER SPECIFICATION **************************** -- -- This procedure writes an entire message from the transport level -- to the NVT printer. ----------------------------------------------------------------------------- END message_processing ; -- package specification -- File : amesspac -- 5/8/85 9:10 AM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT WITH debug_io ; PACKAGE BODY message_processing IS ------------------ FUNCTION there_is_a_message_available -- body ---------------------------- RETURN BOOLEAN IS BEGIN RETURN virtual_transport_level.there_is_a_message ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac.there_is_msg") ; RAISE ; END there_is_a_message_available ; -- function body PROCEDURE retrieve_message -- body ---------------- (message : OUT message_from_transport_level_type ; length : OUT bit_count_16_type) IS BEGIN IF virtual_transport_level.there_is_a_message THEN virtual_transport_level.get_message(message, length) ; ELSE -- error length := 0 ; -- no message available, erronious call END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac.retr_msg") ; RAISE ; END retrieve_message ; -- procedure body PROCEDURE write_message_to_NVT_printer -- body ---------------------------- (transport_level_message : IN message_from_transport_level_type ; length : IN bit_count_16_type) IS BEGIN FOR index IN 1..length LOOP virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, transport_level_message(index)) ; END LOOP ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac.write_msg_nvt") ; RAISE ; END write_message_to_NVT_printer ; -- procedure body BEGIN NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac instantiation") ; RAISE ; END message_processing ; -- package body --:::::::::::::: --aplpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01205-100(-) -- E-Systems, Inc. August 07, 1985 -- -- aplpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : aplpac AUTHOR : MIKE THOMAS -- 5/9/85 1:20 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 11:29 AM : modify for telesoft to run on wicat PACKAGE telnet_apl -- specification ---------- IS --************************ USER SPECIFICATION ****************************** -- -- TELNET APPLICATION PROTOCOL LEVEL SPECIFICATION -- -- The Application Protocol Level (APL)... [1] -- -- * defines the semantics for information exchange; [2] -- * provides network transparency; [3] -- * and partitions the problem into high level functional areas : [4] -- : read/write characters from/to the Network Virtual Terminal (NVT) -- via the Presentation Protocol Level (PPL), -- : handle standard control functions (ip, ao, ayt, ec, and el), -- : perform command parsing, -- : pass the commands to the Presentation Protocol Level (PPL) for -- submission to the transport level protocol, -- : receive responses/messages from the transport level protocol via the -- Presentation Protocol Level (PPL). -- -- SPECIFICATION REFERENCES: -- -- DOD Protocol Reference Model (contract DCA 100-82-C-0036 2-Dec-83) -- -- [1] section 4.1.1 -- [2] section 4.1.1.1 -- [3] section 4.1.1.2 -- [4] section 4.1.1.3 -- ----------------------------------------------------------------------------- -- ************************************************************************** -- -- This package performs the TELNET application protocol level(APL) processing -- and imports procedures to access the TELNET presentation protocol -- level(PPL). This package is responsible for the semantics of the user -- information exchange and uses the virtual resources provided for by the PPL -- to access the network virtual terminal(NVT) and virtual transport level. -- For example, this level could access the NVT to get user/process input -- to TELNET; determine that it was a proper TELNET command to open a new -- connection and call upon the virtual transport level to establish the -- new connection. If the real world terminal type were to change or the -- transport level's actual implementation were changed, this would have no -- effect on the APL. -- -- **************************************************************************** PROCEDURE process_any_input_from_the_nvt_keyboard ; -- specification -- ************************ USER SPECIFICATION **************************** -- -- This procedure will input and process one character from the NVT -- keyboard if one is available. ----------------------------------------------------------------------------- PROCEDURE process_any_messages_from_the_transport_level ; -- specification -- ************************ USER SPECIFICATION **************************** -- -- This procedure will input and process one entire message from the -- transport level if a message is available. A message being information -- for the local user/process which was generated by the local transport -- level, not simply data being relayed from the remote TELNET. ----------------------------------------------------------------------------- PROCEDURE process_any_input_from_the_transport_level ; -- specification -- ************************ USER SPECIFICATION **************************** -- -- This procedure will input and process one character from the -- transport level which was relayed from the remote TELNET if it is -- available. ----------------------------------------------------------------------------- PROCEDURE transmit_telnet_go_ahead ; -- specification -- ************************ USER SPECIFICATION **************************** -- -- This procedure will send the TELNET GA signal to the remote TELNET. ----------------------------------------------------------------------------- END telnet_apl ; -- package specification -- File : aplpac AUTHOR : MIKE THOMAS -- 5/9/85 1:25 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 6/23/85 9:00 PM : set ga_state := no_ga_sent if there is input from tcp -- 6/24/85 10:19 AM : move set go_ahead to not control func part of if stm -- 7/16/85 11:29 AM : modify for telesoft to run on wicat WITH nvt_keyboard_input_processing ; -- procedures used in USE nvt_keyboard_input_processing ; -- process_any_input_from_the_nvt_keyboard WITH message_processing ; -- procedures/data/types used in USE message_processing ; -- process_any_messages_from_the_transport_level WITH transport_level_input_processing ; -- procedures used in USE transport_level_input_processing ; -- process_any_input_from_the_transport_level WITH user_data ; -- state information, user buffers, and data types USE user_data ; WITH virtual_terminal ; -- for local character echoing WITH virtual_transport_level ; -- to send telnet go ahead, echo data to remote WITH SYSTEM ; -- for access to system.byte WITH debug_io ; PACKAGE BODY telnet_apl IS ---------- SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; PROCEDURE process_any_input_from_the_nvt_keyboard -- body --------------------------------------- IS -- ********************* BODY SPECIFICATION ******************************* -- -- Processing sequence : -- -- While there is input to process... -- If there is input from the NVT keyboard, get a character. Set the -- NVT I/O state as I/O-done. If the character was a standard control -- function, process the standard control function. If the character was -- not a control function then process it as follows. If the -- communication state is no-connection-established or the command state -- is partial-command or a new command was detected then set the NVT I/O -- state as partial-command and process a partial command. Otherwise the -- input is data so put the character in the data buffer until an end of -- line is detected and then send it through to the transport level. ---------------------------- data declarations --------------------------- char : bit_count_8_type ; end_of_line : CONSTANT bit_count_8_type := 16#0D# ; -- ASCII.CR TYPE control_function IS (ip, ao, ayt, ec, el) ; the_char_was_a_control_function : BOOLEAN ; standard_control_function : control_function ; at_char : CONSTANT bit_count_8_type := 16#40# ; -- ascii '@' (command character) last_char_was_an_at : BOOLEAN RENAMES user_control_block.last_keybd_char_was_cmd ; ------------------------- local procedure declarations -------------------- PROCEDURE check_for_local_printing (char : IN bit_count_8_type) IS ------------------------ remote_options_in_effect : user_data.option_table_type RENAMES user_control_block.option_tables.remote_options_in_effect ; echo_local : BOOLEAN := TRUE ; BEGIN FOR index IN 1..remote_options_in_effect.number_of_items LOOP IF remote_options_in_effect.option(index) = user_data.echo THEN echo_local := FALSE ; EXIT ; END IF ; END LOOP ; IF echo_local THEN virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, char) ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.check_loc_print") ; RAISE ; END check_for_local_printing ; FUNCTION time_to_transmit (char : IN bit_count_8_type) RETURN BOOLEAN IS ---------------- -- ************************* SPECIFICATION ****************************** -- This function returns true if it is time to transmit the characters -- which were typed into the keyboard and are to be sent to the remote -- TELNET connection. In the default NVT options, this would be at the -- end of a line.[1] Other options in effect (such as remote ECHO) may -- be criteria for character-at-a-time as appossed to line-at-a-time -- transmissions.[2] -- -- SPECIFICATION REFERENCES : -- [1] Network Working Group Request For Comments : 854, May 1983 -- (page 5, default condition 1) -- [2] Network Working Group Request For Comments : 857, May 1983 -- (page 3, paragraph 1) --------------------------------------------------------------------------- transmit_time : BOOLEAN := FALSE ; remote_options_in_effect : user_data.option_table_type RENAMES user_control_block.option_tables.remote_options_in_effect ; local_options_in_effect : user_data.option_table_type RENAMES user_control_block.option_tables.local_options_in_effect ; remote_options_pending : user_data.option_table_type RENAMES user_control_block.option_tables.remote_options_pending ; local_options_pending : user_data.option_table_type RENAMES user_control_block.option_tables.local_options_pending ; FUNCTION option_in_table --------------- (table : IN user_data.option_table_type ; option : IN user_data.option_type) RETURN BOOLEAN IS BEGIN FOR index IN 1..table.number_of_items LOOP IF table.option(index) = option THEN RETURN TRUE ; END IF ; END LOOP ; RETURN FALSE ; END option_in_table ; BEGIN IF user_data.user_control_block.ga_received OR option_in_table(remote_options_in_effect, suppress_ga) THEN IF bit_count_16_type(char) = bit_count_16_type(end_of_line) AND THEN (remote_options_pending.number_of_items = 0 AND local_options_pending.number_of_items = 0) THEN transmit_time := TRUE ; -- end of line, no option negotiation pending ELSE -- not end of line IF option_in_table(remote_options_in_effect, suppress_ga) AND option_in_table(local_options_in_effect, suppress_ga) THEN IF option_in_table(remote_options_in_effect, echo) OR option_in_table(local_options_in_effect, echo) THEN transmit_time := TRUE ; -- suppress_ga & echo ==> character at a time mode END IF ; -- echo? END IF ; -- suppress_ga? END IF ; -- end of line? END IF ; -- ga_received? RETURN transmit_time ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.time_to_trans") ; RAISE ; END time_to_transmit ; PROCEDURE process_data_character(char : IN bit_count_8_type) IS ---------------------- BEGIN debug_io.put_line("putting character in data buffer") ; put_character_in_data_buffer(char) ; IF bit_count_16_type(char) = bit_count_16_type(255) THEN -- double IAC on send to indecate a data byte 255 put_character_in_data_buffer(char) ; END IF ; IF time_to_transmit(char) THEN debug_io.put_line("sending data buffer to trans level") ; send_data_buffer_to_transport_level ; END IF ; -- transmit buffer? EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_data_char") ; RAISE ; END process_data_character ; BEGIN -- process keyboard input debug_io.put_line("begin process keyboard input") ; IF there_is_input_from_the_NVT_keyboard THEN WHILE there_is_input_from_the_NVT_keyboard LOOP debug_io.put_line("apl process keyboard input thinks there is input") ; get_a_character(char, the_char_was_a_control_function); check_for_local_printing(char) ; user_control_block.NVT_IO_state := IO_done ; IF the_char_was_a_control_function THEN debug_io.put_line("will process control function...") ; process_standard_control_function_from_keyboard(char) ; ELSE -- not control function debug_io.put_line("character not a control function") ; IF user_control_block.communication_state = no_connection_established OR user_control_block.command_state = partial_command THEN debug_io.put_line("current character is part of partial command") ; user_control_block.command_state := partial_command ; process_partial_command(char) ; ELSE -- data debug_io.put_line("current character is data") ; IF last_char_was_an_at THEN IF bit_count_16_type(char) = bit_count_16_type(at_char) THEN -- put at #2 in data buf process_data_character(char) ; last_char_was_an_at := FALSE ; ELSE -- new command detected user_control_block.command_state := partial_command ; process_partial_command(at_char) ; process_partial_command(char) ; last_char_was_an_at := FALSE ; END IF ; -- char=at? ELSE -- last char /= at IF bit_count_16_type(char) = bit_count_16_type(at_char) THEN last_char_was_an_at := TRUE ; ELSE -- niether last char nor this char = at process_data_character(char) ; END IF ; -- transmit buffer? END IF ; -- last_char_was_an_at? END IF ; -- command? END IF ; -- control function? END LOOP ; -- input from keyboard? ELSE -- no input from keyboard, chack for send of buffered input -- due to pending option negotiation and/or go ahead processing IF user_data.there_is_data_in_data_buffer AND time_to_transmit(0) THEN send_data_buffer_to_transport_level ; END IF ; -- send buffered data? END IF ; -- keyboard input available? debug_io.put_line("end process keyboard input") ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_any_keybd_input") ; RAISE ; END process_any_input_from_the_NVT_keyboard ; -- procedure body PROCEDURE process_any_messages_from_the_transport_level -- body --------------------------------------------- IS --************************ BODY SPECIFICATION ***************************** -- -- While there are messages to process... -- If there is a message from the transport level, retrieve the message and -- write the message to the NVT printer. A message being information -- for the local user/process which was generated by the local transport -- level, not simply data being relayed from the remote TELNET. -------------------------- data declarations --------------------------- message_from_transport_level : message_from_transport_level_type ; length : bit_count_16_type RANGE 1..max_msg_length ; BEGIN -- process_any_messages_from_the_transport_level debug_io.put_line("begin telnet_apl.process_any_messages.") ; WHILE there_is_a_message_available LOOP retrieve_message(message_from_transport_level, length) ; debug_io.put("message length =") ; debug_io.put_line(length) ; write_message_to_NVT_printer(message_from_transport_level, length) ; END LOOP ; -- message to process? debug_io.put_line("end telnet_apl.process_any_messages.") ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_any_mess") ; RAISE ; END process_any_messages_from_the_transport_level ; -- body PROCEDURE process_any_input_from_the_transport_level -- body ------------------------------------------ IS --********************** BODY SPECIFICATION **************************** -- -- Processing sequence : -- -- While there is input to process... -- If there is input from the transport level which is data simply -- relayed from the remote TELNET, input a character from the -- transport level and mark the NVT I/O state as having I/O-done. If the -- character is not a standard control function, write it on the NVT -- printer. If the character is a standard control function, process the -- standard control function. -------------------------- data declarations ------------------------- char : bit_count_8_type ; the_char_was_a_control_function : BOOLEAN ; urgent_data : BOOLEAN := TRUE ; echo_chars : virtual_transport_level.info_output_type (1..virtual_transport_level.max_msg_length) ; char_count : bit_count_16_type RANGE 0..virtual_transport_level.max_msg_length := 0 ; FUNCTION echo_to_remote RETURN BOOLEAN IS -------------- local_options_in_effect : user_data.option_table_type RENAMES user_data.user_control_block.option_tables.local_options_in_effect ; BEGIN FOR index IN 1..local_options_in_effect.number_of_items LOOP IF local_options_in_effect.option(index) = user_data.echo THEN RETURN TRUE ; END IF ; END LOOP ; RETURN FALSE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.ehco_to_remote") ; RAISE ; END echo_to_remote ; BEGIN -- process_any_input_from_transport_level debug_io.put_line ("begin telnet_apl.process_any_input_from_transport_level") ; WHILE there_is_input LOOP debug_io.put_line ("telnet_apl.process_any_input thinks there is input") ; input_character(char, the_char_was_a_control_function, urgent_data) ; debug_io.put("telnet_apl.proc_input.char=") ; debug_io.put_line_byte(char) ; IF the_char_was_a_control_function THEN debug_io.put_line("was a control function") ; process_standard_control_function(char, urgent_data) ; ELSE debug_io.put_line("was not a control function") ; user_data.user_control_block.ga_state := no_go_ahead_sent ; write_character_to_NVT_printer(char) ; user_control_block.NVT_IO_state := IO_done ; char_count := char_count + 1 ; echo_chars(char_count) := char ; END IF ; -- control function? END LOOP ; -- any input to process? IF echo_to_remote AND char_count > 0 THEN virtual_transport_level.send_data(echo_chars(1..char_count),urgent_data) ; END IF ; debug_io.put_line ("end telnet_apl.process_any_input_from_transport_level") ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_tl_input") ; RAISE ; END process_any_input_from_the_transport_level ; -- body PROCEDURE transmit_telnet_go_ahead -- body ------------------------ IS --************************* BODY SPECIFICATION *************************** -- -- Processing sequence ... -- -- Send the TELNET GA (go ahead) signal through the presentation level -- to the transport level. -------------------------- data declarations ----------------------------- SUBTYPE telnet_go_ahead_type IS virtual_transport_level.info_output_type(1..2) ; telnet_go_ahead : telnet_go_ahead_type ; not_urgent : BOOLEAN := FALSE ; BEGIN -- transmit_telnet_go_ahead debug_io.put_line("telnet go ahead sent") ; telnet_go_ahead(1) := 16#FF# ; -- RFC 854 page 14 telnet_go_ahead(2) := 16#F9# ; IF virtual_transport_level.there_is_room_for_info_output THEN virtual_transport_level.send_data (telnet_go_ahead, not_urgent) ; END IF ; END transmit_telnet_go_ahead ; -- body BEGIN -- telnet APL package body NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac instantiation") ; RAISE ; END telnet_apl ; -- package --:::::::::::::: --atrinpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01206-100(-) -- E-Systems, Inc. August 07, 1985 -- -- atrinpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : atrinpac -- 5/8/85 9:25 AM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 1:52 PM : mod for telesoft for wicat WITH SYSTEM ; -- to get access to system.byte PACKAGE transport_level_input_processing -- specification -------------------------------- IS -- ************************** USER SPECIFICATION **************************** -- -- This package provides subprograms to process (at the APL level) data -- input to TELNET relayed from the remote TELNET. -- -- ************************************************************************** SUBTYPE bit_count_32_type IS LONG_INTEGER ; --&MT SUBTYPE bit_count_32_type IS INTEGER ; SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; SUBTYPE character_type IS bit_count_8_type ; FUNCTION there_is_input -- specification -------------- RETURN BOOLEAN ; -- ************************ USER SPECIFICATION **************************** -- -- This function returns true if there is data input available from the -- remote TELNET. ----------------------------------------------------------------------------- PROCEDURE input_character -- specification --------------- (char : OUT character_type ; control_function : OUT BOOLEAN ; urgent_data : OUT BOOLEAN) ; -- ************************ USER SPECIFICATION **************************** -- -- This procedure returns a character sent from the remote TELNET and -- indicates whether it is to be interpreted as a control function. ----------------------------------------------------------------------------- PROCEDURE process_standard_control_function -- specification --------------------------------- (char : IN character_type ; urgent_data : IN BOOLEAN) ; -- ************************ USER SPECIFICATION **************************** -- -- This procedure processes a control function which was received from -- the remote TELNET connection. ----------------------------------------------------------------------------- PROCEDURE write_character_to_NVT_printer -- specification ------------------------------ (char : IN character_type) ; -- ************************ USER SPECIFICATION **************************** -- -- This routine writes a character to the NVT printer. ----------------------------------------------------------------------------- END transport_level_input_processing ; -- package specification -- File : atrinpac -- 5/8/85 9:37 AM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 1:52 PM : mod for telesoft for wicat WITH virtual_transport_level ; WITH virtual_terminal ; WITH option_negotiation ; WITH user_data ; WITH debug_io ; PACKAGE BODY transport_level_input_processing -------------------------------- IS -- ********************* BODY SPECIFICATION ********************************* -- -- This package provides subprograms to process (at the APL level) data -- input to TELNET from the transport level. Make the appropriate calls -- to the lower level APL packages which will in turn call routines from -- the PPL. Data input is data sent from the remote TELNET. -- -- **************************************************************************** FUNCTION there_is_input -- body -------------- RETURN BOOLEAN IS BEGIN RETURN virtual_transport_level.there_is_input ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.there_is_input") ; RAISE ; END there_is_input ; -- function body PROCEDURE input_character -- body --------------- (char : OUT character_type ; control_function : OUT BOOLEAN ; urgent_data : OUT BOOLEAN) IS -- ************************ BODY SPECIFICATION **************************** -- -- This procedure returns a character sent from the remote TELNET -- and indicates whether it is to be interpreted as a control function. -- Characters which are part of a synch are flagged as a control function. -- The urgent data flag or the user_data.synch_in_progress = TRUE indicates -- that the current character is to be interpreted as a control function. -- If the character is an IAC(Interperate As Command), get another -- character. If the second character is not an IAC it is a command and to -- be interpreted as a control function. (This will also have the effect of -- of screening out the doubling of the IAC code done by the remote TELNET -- when it is not to be interpreted as an IAC, ie. the data byte 255.) -- A call to this procedure without checking for the presence of characters -- to input is erroneous but will result in char := 0 and control_function -- := FALSE. ----------------------------------------------------------------------------- IAC : CONSTANT character_type := 255 ; -- interprate as command code temp_char : character_type; temp_control_function : BOOLEAN; temp_urgent_data : BOOLEAN; BEGIN temp_char := 0 ; temp_control_function := FALSE ; IF virtual_transport_level.there_is_input THEN virtual_transport_level.get_input(temp_char, temp_urgent_data) ; IF user_data.user_control_block.synch_is_in_progress OR temp_urgent_data THEN -- special handling required temp_control_function := TRUE ; debug_io.put("atrinpac.input_character: control func detected, code=") ; debug_io.put_line_byte(temp_char) ; END IF ; IF bit_count_16_type(temp_char) = bit_count_16_type(IAC) THEN WHILE NOT(virtual_transport_level.there_is_input) LOOP NULL ; END LOOP ; virtual_transport_level.get_input(temp_char, temp_urgent_data) ; IF bit_count_16_type(temp_char) /= bit_count_16_type(IAC) THEN -- command IAC temp_control_function := TRUE ; END IF ; END IF ; END IF ; char := temp_char; control_function := temp_control_function; urgent_data := temp_urgent_data; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.input_chr") ; RAISE ; END input_character ; -- procedure body PROCEDURE process_standard_control_function -- body --------------------------------- (char : IN character_type ; urgent_data : IN BOOLEAN) IS -- ************************ BODY SPECIFICATION **************************** -- -- This procedure processes a control function which was received from -- the remote TELNET. Handling of the TELNET synch mechanism is also done -- here as follows. The synch is sent via the transport level send -- operation with the urgent flag set and the data mark (DM) as the last -- (or only) data octet. If the transport level urgent data flag is set, -- the data stream is scanned for IP, AO, AYT, and DM signals. -- When in normal mode, the DM is a no-op; when in urgent mode, it signals -- the end of urgent processing. If the transport level indicates the end -- of urgent data before the DM is found, TELNET will continue special -- handling of the data stream until the DM is found. If more urgent data is -- indicated after the DM is found, TELNET will continue special handling -- of the data stream until the DM is found. NOTE: Site dependent code used -- for the IP and BREAK commands. -- See RFC 854, page 9 for details on the TELNET synch mechanism. ----------------------------------------------------------------------------- option_code : bit_count_8_type ; control_function : BOOLEAN ; urgent_flag : BOOLEAN ; urgent : CONSTANT BOOLEAN := TRUE ; not_urgent : CONSTANT BOOLEAN := FALSE ; BEGIN -- process_standard_control_function debug_io.put_line("begin atrinpac.process_standard_control_function") ; IF user_data.user_control_block.synch_is_in_progress THEN debug_io.put("synch is in progress,") ; ELSE debug_io.put("synch is NOT in progress,") ; END IF ; IF urgent_data THEN debug_io.put(" urgent data,") ; ELSE debug_io.put(" NOT urgent data,") ; END IF ; debug_io.put(" char_code=") ; debug_io.put_line_byte(char) ; IF user_data.user_control_block.synch_is_in_progress OR urgent_data THEN user_data.user_control_block.synch_is_in_progress := TRUE ; END IF ; CASE char IS -- handle non synch char WHEN 240 | 241 | 250 => -- SE, NOP, SB (RFC 854, p. 14) NULL ; -- nop for now WHEN 242 => -- DM user_data.user_control_block.synch_is_in_progress := FALSE ; WHEN 243 => -- break ****** NOTE: SITE DEPENDENT CODE USED ****** virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, 3) ; -- ctrl c for VAX WHEN 244 => -- IP ****** NOTE: SITE DEPENDENT CODE USED ****** virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, 25) ; -- ctrl y for VAX WHEN 245 => -- AO DECLARE -- (RFC 854, P. 7,8,&14) buffer : user_data.string_type(1..user_data.max_out_string) ; length : bit_count_16_type ; data_mark : virtual_transport_level.info_output_type(1..1) ; BEGIN -- declare data_mark(1) := 242 ; user_data.get_data_buffer(buffer, length) ; -- trash rest of buffer virtual_transport_level.send_data(data_mark, urgent) ; -- synch END ; -- declare WHEN 246 => -- AYT (RFC 854, P. 13,14) DECLARE ayt_responce : STRING(1..12) := " I AM HERE. " ; ayt_responce_vtl : virtual_transport_level.info_output_type(1..12); BEGIN -- delcare ayt_responce(1) := ASCII.CR ; ayt_responce(12) := ASCII.CR ; FOR index IN ayt_responce'RANGE LOOP -- convert type ayt_responce_vtl(bit_count_16_type(index)) := bit_count_8_type(CHARACTER'POS(ayt_responce(index))) ; END LOOP ; virtual_transport_level.send_data(ayt_responce_vtl, not_urgent) ; END ; -- declare WHEN 247 => -- EC (RFC 854, P. 13,14) IF user_data.there_is_data_in_data_buffer AND user_data.user_control_block.synch_is_in_progress = FALSE THEN DECLARE buffer : user_data.out_string_type ; length : bit_count_16_type RANGE 1..user_data.max_out_string ; BEGIN -- declare user_data.get_data_buffer(buffer, length) ; user_data.put_string_in_data_buffer(buffer(1..length - 1)) ; END ; -- declare END IF ; WHEN 248 => -- EL IF user_data.there_is_data_in_data_buffer AND user_data.user_control_block.synch_is_in_progress = FALSE THEN DECLARE buffer : user_data.out_string_type ; length : bit_count_16_type RANGE 1..user_data.max_out_string ; BEGIN -- declare user_data.get_data_buffer(buffer, length) ; FOR index IN REVERSE 1..length LOOP -- delete up to CRLF IF bit_count_16_type(buffer(index)) = 10 THEN -- line feed IF index > 1 AND THEN bit_count_16_type(buffer(index - 1)) = 13 THEN -- cr user_data.put_string_in_data_buffer(buffer(1..index)) ; EXIT ; -- loop END IF ; -- CR? END IF ; -- LF? END LOOP ; -- delete up to CRLF END ; -- declare END IF ; -- data in buffer and no synch in progress? WHEN 249 => -- GA user_data.user_control_block.ga_received := TRUE ; WHEN 251 => -- WILL (option code) -- get option code WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ; END LOOP ; virtual_transport_level.get_input(option_code, urgent_flag) ; option_negotiation.remote_will_received(option_code) ; WHEN 252 => -- WON'T (option code) -- get option code WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ; END LOOP ; virtual_transport_level.get_input (option_code, urgent_flag) ; option_negotiation.remote_wont_received(option_code) ; WHEN 253 => -- DO (option code) -- get option code WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ; END LOOP ; virtual_transport_level.get_input(option_code, urgent_flag) ; option_negotiation.remote_do_received(option_code) ; WHEN 254 => -- DON'T (option code) -- get option code WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ; END LOOP ; virtual_transport_level.get_input(option_code, urgent_flag) ; option_negotiation.remote_dont_received(option_code) ; WHEN OTHERS => -- error NULL ; END CASE ; -- handle non synch char debug_io.put_line("begin atrinpac.process_standard_control_function") ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.proc_std_cf") ; debug_io.put("char=") ; debug_io.put_line_byte(char) ; RAISE ; END process_standard_control_function ; -- procedure body PROCEDURE write_character_to_NVT_printer -- body ------------------------------ (char : IN character_type) IS BEGIN virtual_terminal.output_character_to_nvt_printer (user_data.user_control_block.port, char) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.write_chr") ; RAISE ; END write_character_to_NVT_printer ; -- procedure body BEGIN NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac instantiation") ; RAISE ; END transport_level_input_processing ; -- package body --:::::::::::::: --auserdpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01207-100(-) -- E-Systems, Inc. August 07, 1985 -- -- auserdpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : auserdpac Author : Mike Thomas -- 5/22/85 9:20 AM : MODIFY FOR DEC ADA -- OLD CODE MARKED AS --&MT -- 6/11/85 5:14 PM : lcn changed from lcn_type to lcn_ptr_type -- 6/23/85 9:38 PM : init ga_state to no go_ahead_sent -- 7/16/85 1:58 PM : mods for telesoft for wicat --&MT PRAGMA SOURCE_INFO(ON) ; -- ask TeleSoft to provide run-time error reports WITH SYSTEM ; WITH virtual_terminal ; WITH with_ulp_communicate ; -- access lcn_type WITH buffer_data ; -- access sixteen_bits type WITH t_tcp_globals_data_structures ; USE t_tcp_globals_data_structures ; PACKAGE user_data -- specification --------- IS -- ********************** USER SPECIFICATION ******************************** -- -- This package contains the user buffers -- and state information. The state information types and the maximum -- user command length are also exported. -- -- **************************************************************************** ----------------------- data (object) declarations ----------------------- SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; -- state information maintained for each user TYPE nvt_io_state_type IS (io_done, no_io_done) ; TYPE communication_state_type IS (connection_established, no_connection_established) ; TYPE command_state_type IS (partial_command, no_partial_command) ; TYPE go_ahead_sent_state_type IS (go_ahead_sent, no_go_ahead_sent) ; -- maximum user command string length (might use in partial cmd) max_cmd_length : CONSTANT bit_count_16_type := 80 ; -- arbitrary, make defered constant when supported TYPE string_type IS ARRAY (bit_count_16_type RANGE <>) OF bit_count_8_type ; max_out_string : CONSTANT bit_count_16_type := 256 ; -- largest ucb buffer size SUBTYPE out_string_type IS string_type(1..max_out_string) ; -- buffer space maintained for each user SUBTYPE partial_command_buf_length IS bit_count_16_type RANGE 0..max_cmd_length ; TYPE partial_cmd_buffer_type IS ARRAY (1..max_cmd_length) OF bit_count_8_type ; TYPE partial_command_buffer_type IS RECORD buffer : partial_cmd_buffer_type ; length : partial_command_buf_length := 0 ; END RECORD ; data_buffer_length : CONSTANT bit_count_16_type := 100 ; -- arbitrary SUBTYPE data_buf_ptr IS bit_count_16_type RANGE 0..data_buffer_length - 1 ; TYPE data_buf_type IS ARRAY (0..data_buffer_length - 1) OF bit_count_8_type ; TYPE data_buffer_type IS RECORD buffer : data_buf_type ; buf_head : data_buf_ptr := 0 ; buf_tail : data_buf_ptr := 1 ; END RECORD ; ------------------------------- option tables ------------------------------- TYPE option_type IS (echo,suppress_ga) ; -- list of all options currently supported number_of_options_supported : CONSTANT bit_count_16_type := 2 ; TYPE option_array_type IS ARRAY (1..number_of_options_supported) OF option_type ; SUBTYPE option_count_type IS bit_count_16_type RANGE 0..number_of_options_supported ; TYPE option_table_type IS RECORD option : option_array_type ; number_of_items : option_count_type := 0 ; END RECORD ; TYPE option_tables_type IS RECORD local_options_desired : option_table_type ; local_options_pending : option_table_type ; local_options_in_effect : option_table_type ; remote_options_desired : option_table_type ; remote_options_pending : option_table_type ; remote_options_in_effect : option_table_type ; END RECORD ; -- These structures contain buffers which are used to communicate with the -- transport level. The trans_input_buffer and trans_output_buffer are -- tightly coupled to the transport level and contain both messages and data. -- (after link-up to TCP these debug buffers will not be used) -- The other buffers are loosely coupled and have exclusivly data or messages. -- -- **************************************************************************** -- transport level input buffer containing messages and data -- direct channel to TCP (actual form will change) -- this for debug --MT trans_in_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary --MT SUBTYPE trans_in_buf_ptr IS bit_count_16_type --MT RANGE 0..trans_in_buffer_length - 1 ; --MT TYPE trans_input_buffer_type IS ARRAY (0..trans_in_buffer_length - 1) --MT OF bit_count_8_type ; --MT TYPE trans_input_buffer_record IS --MT RECORD --MT buffer : trans_input_buffer_type ; --MT buf_head : trans_in_buf_ptr := 0 ; --MT buf_tail : trans_in_buf_ptr := 1 ; --MT END RECORD ; -- transport level output buffer containing messages and data -- direct channel to TCP (actual form will change) -- this for debug --MT trans_out_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary --MT SUBTYPE trans_out_buf_length IS bit_count_16_type RANGE 0..trans_out_buffer_length ; --MT TYPE trans_output_buffer_type IS ARRAY (1..trans_out_buffer_length) --MT OF bit_count_8_type ; --MT TYPE trans_output_buffer_record IS --MT RECORD --MT buffer : trans_output_buffer_type ; --MT length : trans_out_buf_length := 0 ; --MT END RECORD ; -- transport level to telnet messages -- these buffers not "directly" connected to the transport level trans_to_telnet_msg_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary SUBTYPE trans_to_telnet_msg_buf_ptr_type IS bit_count_16_type RANGE 0..trans_to_telnet_msg_buffer_length - 1 ; TYPE trans_to_telnet_msg_buffer_type IS ARRAY (0..trans_to_telnet_msg_buffer_length - 1) OF bit_count_8_type ; TYPE trans_to_telnet_messages_record IS RECORD buffer : trans_to_telnet_msg_buffer_type ; buf_head : trans_to_telnet_msg_buf_ptr_type := 0 ; buf_tail : trans_to_telnet_msg_buf_ptr_type := 1 ; END RECORD ; -- transport level to telnet data -- these buffers not "directly" connected to the transport level trans_to_telnet_data_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary SUBTYPE trans_to_telnet_data_buf_ptr_type IS bit_count_16_type RANGE 0..trans_to_telnet_data_buffer_length - 1 ; TYPE trans_to_telnet_data_buffer_type IS ARRAY (0..trans_to_telnet_data_buffer_length - 1) OF bit_count_8_type ; TYPE trans_to_telnet_data_record IS RECORD buffer : trans_to_telnet_data_buffer_type ; buf_head : trans_to_telnet_data_buf_ptr_type := 0 ; buf_tail : trans_to_telnet_data_buf_ptr_type := 1 ; END RECORD ; TYPE ppl_trans_buffers_type IS RECORD --MT trans_input_buffer : trans_input_buffer_record ; -- debug --MT trans_output_buffer : trans_output_buffer_record ; -- debug trans_to_telnet_messages : trans_to_telnet_messages_record ; trans_to_telnet_data : trans_to_telnet_data_record ; END RECORD ; TYPE control_block_type IS -- (contains state information etc. for a user) RECORD port : virtual_terminal.port_number ; tl_port_number : buffer_data.sixteen_bits ; -- transport level local port # lcn : tcb_ptr ; -- TCP local_connection_number NVT_IO_state : NVT_IO_state_type := IO_done ; communication_state : communication_state_type := no_connection_established ; command_state : command_state_type := no_partial_command ; GA_state : go_ahead_sent_state_type := no_go_ahead_sent ; GA_received : BOOLEAN := FALSE ; synch_is_in_progress : BOOLEAN := FALSE ; last_keybd_char_was_cmd : BOOLEAN := FALSE ; rcv_data_is_urgent : BOOLEAN := FALSE ; last_data_char_rcv_not_cr : BOOLEAN := TRUE ; partial_command_buffer : partial_command_buffer_type ; data_buffer : data_buffer_type ; option_tables : option_tables_type ; trans_buffers : ppl_trans_buffers_type ; END RECORD ; user_control_block : control_block_type ; ------------------- end data (object) declarations ----------------------- --------------- function/procedure (verb) specifications ----------------- -- partial command data buffer manipulation functions/procedures FUNCTION there_is_data_in_command_buffer -- specification ------------------------------- RETURN BOOLEAN ; -- *********************** USER SPECIFICATION ***************************** -- -- This function returns true if there is data in the APL command buffer. ----------------------------------------------------------------------------- FUNCTION there_is_room_in_command_buffer -- specification ------------------------------- RETURN BOOLEAN ; -- room for a character -- *********************** USER SPECIFICATION ***************************** -- -- This function returns true if there is room for a character in the -- APL command buffer. ----------------------------------------------------------------------------- PROCEDURE put_char_in_command_buffer -- specificaton -------------------------- (char : IN bit_count_8_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure will add a character to the APL command buffer. The -- user should make sure there is room in the buffer before calling this -- procedure. If the NVT output buffer is full, the character will be lost. ----------------------------------------------------------------------------- PROCEDURE put_string_in_command_buffer -- specificaton ---------------------------- (str : IN string_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure will add characters to the APL command buffer. If there -- is not enough room in the buffer for all the characters, then the -- extra characters will be lost. ----------------------------------------------------------------------------- PROCEDURE get_char_from_command_buffer -- specificaton ---------------------------- (char : OUT bit_count_8_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure returns the next character from the APL command buffer. -- The user should determine that there are characters in the buffer before -- calling this procedure. If the buffer is empty, this procedure will -- return null. ----------------------------------------------------------------------------- PROCEDURE get_command_buffer -- specificaton ------------------ (buffer : OUT out_string_type ; length : OUT bit_count_16_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure returns the entire contents of the APL command buffer. -- The user should determine that there are characters in the buffer before -- calling this procedure. If the buffer is empty, this procedure will -- return null. ----------------------------------------------------------------------------- -- data buffer manipulation functions/procedures FUNCTION there_is_data_in_data_buffer -- specification ---------------------------- RETURN BOOLEAN ; -- *********************** USER SPECIFICATION ***************************** -- -- This function returns true if there is data in the APL data buffer. ----------------------------------------------------------------------------- FUNCTION there_is_room_in_data_buffer -- specification ---------------------------- RETURN BOOLEAN ; -- room for a character -- *********************** USER SPECIFICATION ***************************** -- -- This function returns true if there is room for a character in the -- APL data buffer. ----------------------------------------------------------------------------- PROCEDURE put_char_in_data_buffer -- specificaton ----------------------- (char : IN bit_count_8_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure will add a character to the APL data buffer. The -- user should make sure there is room in the buffer before calling this -- procedure. If the NVT output buffer is full, the character will be lost. ----------------------------------------------------------------------------- PROCEDURE put_string_in_data_buffer -- specificaton ------------------------- (str : IN string_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure will add characters to the data buffer. If there -- is not enough room in the buffer for all the characters, the -- excess characters will be lost. ----------------------------------------------------------------------------- PROCEDURE get_char_from_data_buffer -- specificaton ------------------------- (char : OUT bit_count_8_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure returns the next character from the APL data buffer. -- The user should determine that there are characters in the buffer before -- calling this procedure. If the buffer is empty, this procedure will -- return null. ----------------------------------------------------------------------------- PROCEDURE get_data_buffer -- specificaton --------------- (buffer : OUT out_string_type ; length : OUT bit_count_16_type) ; -- *********************** USER SPECIFICATION ***************************** -- -- This procedure returns the entire contents of the APL data buffer. -- The user should determine that there are characters in the buffer before -- calling this procedure. If the buffer is empty, this procedure will -- return null. ----------------------------------------------------------------------------- PROCEDURE get -- specification --- (user_control_block_out : OUT control_block_type) ; -- ********************** USER SPECIFICATION **************************** -- -- This procedure returns the contents of the entire user control block -- which contains state information and buffers for the TELNET user. ------------------------------------------------------------------------- PROCEDURE put -- specification --- (user_control_block_in : IN control_block_type) ; -- ********************** USER SPECIFICATION **************************** -- -- This procedure assigns the contents of the entire user control block -- which contains state information and buffers for the TELNET user. ------------------------------------------------------------------------- PROCEDURE reset_user_control_block ; ------------------------ -- ********************** USER SPECIFICATION **************************** -- -- This procedure resets the user control block as a result of a connection -- closing due to abort or a normal close. --------------------------------------------------------------------------- ----------- end function/procedure (verb) specifications ----------------- END user_data ; -- package specification -- File : auserdpac Author : Mike Thomas -- 5/22/85 9:20 AM : MODIFY FOR DEC ADA -- OLD CODE MARKED AS --&MT -- 6/26/85 10:17 AM : reset ga_state to no_go_ahead_sent -- 7/16/85 1:58 PM : mods for telesoft for wicat WITH debug_io ; PACKAGE BODY user_data --------- IS -- partial command data buffer manipulation functions/procedures FUNCTION there_is_data_in_command_buffer -- body ------------------------------- RETURN BOOLEAN IS BEGIN RETURN user_control_block.partial_command_buffer.length /= 0 ; END there_is_data_in_command_buffer ; -- body FUNCTION there_is_room_in_command_buffer -- body -- room for a character ------------------------------- RETURN BOOLEAN IS BEGIN RETURN user_control_block.partial_command_buffer.length < max_cmd_length ; END there_is_room_in_command_buffer ; -- body PROCEDURE put_char_in_command_buffer -- body -------------------------- (char : IN bit_count_8_type) IS length : partial_command_buf_length RENAMES user_control_block.partial_command_buffer.length ; buffer : partial_cmd_buffer_type RENAMES user_control_block.partial_command_buffer.buffer ; BEGIN IF there_is_room_in_command_buffer THEN length := length + 1 ; buffer(length) := char ; END IF ; END put_char_in_command_buffer ; -- body PROCEDURE put_string_in_command_buffer -- body ---------------------------- (str : IN string_type) IS BEGIN FOR index IN str'RANGE LOOP put_char_in_command_buffer(str(index)) ; END LOOP ; END put_string_in_command_buffer ; -- body PROCEDURE get_char_from_command_buffer -- body ---------------------------- (char : OUT bit_count_8_type) IS length : partial_command_buf_length RENAMES user_control_block.partial_command_buffer.length ; buffer : partial_cmd_buffer_type RENAMES user_control_block.partial_command_buffer.buffer ; BEGIN char := 0 ; IF there_is_data_in_command_buffer THEN char := buffer(1) ; buffer(1..length - 1) := buffer(2..length) ; length := length - 1 ; END IF ; END get_char_from_command_buffer ; -- body PROCEDURE get_command_buffer -- body ------------------ (buffer : OUT out_string_type ; length : OUT bit_count_16_type) IS cmd_length : partial_command_buf_length RENAMES user_control_block.partial_command_buffer.length ; cmd_buffer : partial_cmd_buffer_type RENAMES user_control_block.partial_command_buffer.buffer ; buffer_length : CONSTANT bit_count_16_type := cmd_length ; BEGIN length := cmd_length ; cmd_length := 0 ; FOR index IN 1..buffer_length LOOP buffer(index):= cmd_buffer(index) ; END LOOP ; END get_command_buffer ; -- body -- data buffer manipulation functions/procedures FUNCTION there_is_data_in_data_buffer -- body ---------------------------- RETURN BOOLEAN IS data : data_buffer_type RENAMES user_control_block.data_buffer ; BEGIN RETURN (data.buf_head + 1) MOD data_buffer_length /= data.buf_tail ; END there_is_data_in_data_buffer ; -- body FUNCTION there_is_room_in_data_buffer -- body (room for a character) ---------------------------- RETURN BOOLEAN IS data : data_buffer_type RENAMES user_control_block.data_buffer ; BEGIN RETURN data.buf_head /= data.buf_tail ; END there_is_room_in_data_buffer ; -- body PROCEDURE put_char_in_data_buffer -- body ----------------------- (char : IN bit_count_8_type) IS data : data_buffer_type RENAMES user_control_block.data_buffer ; BEGIN IF there_is_room_in_data_buffer THEN data.buffer(data.buf_tail) := char ; data.buf_tail := (data.buf_tail + 1) MOD data_buffer_length ; END IF ; END put_char_in_data_buffer ; -- body PROCEDURE put_string_in_data_buffer -- body ------------------------- (str : IN string_type) IS BEGIN FOR index IN str'RANGE LOOP put_char_in_data_buffer(str(index)) ; END LOOP ; END put_string_in_data_buffer ; -- body PROCEDURE get_char_from_data_buffer -- body ------------------------- (char : OUT bit_count_8_type) IS data : data_buffer_type RENAMES user_control_block.data_buffer ; BEGIN char := 0 ; IF there_is_data_in_data_buffer THEN data.buf_head := (data.buf_head + 1) MOD data_buffer_length ; char := data.buffer(data.buf_head) ; END IF ; END get_char_from_data_buffer ; -- body PROCEDURE get_data_buffer -- body --------------- (buffer : OUT out_string_type ; length : OUT bit_count_16_type) IS data : data_buffer_type RENAMES user_control_block.data_buffer ; buffer_length : bit_count_16_type := 0 ; BEGIN WHILE (data.buf_head + 1) MOD data_buffer_length /= data.buf_tail LOOP data.buf_head := (data.buf_head + 1) MOD data_buffer_length ; buffer_length := buffer_length + 1 ; buffer(buffer_length) := data.buffer(data.buf_head) ; END LOOP ; length := buffer_length ; END get_data_buffer ; -- body PROCEDURE get -- body --- (user_control_block_out : OUT control_block_type) IS BEGIN user_control_block_out := user_control_block ; END get ; -- body PROCEDURE put -- body --- (user_control_block_in : IN control_block_type) IS BEGIN user_control_block := user_control_block_in ; END put ; -- body PROCEDURE reset_user_control_block IS ------------------------ ucb : control_block_type RENAMES user_control_block ; BEGIN -- restore default values ucb.nvt_io_state := io_done ; ucb.communication_state := no_connection_established ; ucb.command_state := no_partial_command ; ucb.ga_state := no_go_ahead_sent ; ucb.ga_received := FALSE ; ucb.synch_is_in_progress := FALSE ; ucb.last_keybd_char_was_cmd := FALSE ; ucb.rcv_data_is_urgent := FALSE ; ucb.last_data_char_rcv_not_cr := TRUE ; ucb.partial_command_buffer.length := 0 ; ucb.option_tables.local_options_pending.number_of_items := 0 ; ucb.option_tables.local_options_in_effect.number_of_items := 0 ; ucb.option_tables.remote_options_pending.number_of_items := 0 ; ucb.option_tables.remote_options_in_effect.number_of_items := 0 ; END reset_user_control_block ; BEGIN -- user_data NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN user_data instantiation") ; RAISE ; END user_data ; -- package body --:::::::::::::: --debugio.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01208-100(-) -- E-Systems, Inc. August 07, 1985 -- -- debugio.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : debugio Author : Mike Thomas -- 5/22/85 8:10 AM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:15 PM : mods for telesoft wicat WITH SYSTEM ; USE SYSTEM ; PACKAGE debug_io IS -- **************************************************************************** -- -- This package has routines which do output to the CRT or a debug disk file -- or both (or neither). The interface is indended to look similer to -- text_io for string, character and integer output. NOTE : The Wicat -- must close a disk file for it to exist. -- -- **************************************************************************** SUBTYPE bit_count_32_type IS LONG_INTEGER ; --&MT SUBTYPE bit_count_32_type IS INTEGER ; SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; PROCEDURE put (item : IN CHARACTER) ; PROCEDURE put (item : IN STRING) ; PROCEDURE put (item : IN bit_count_16_type) ; --&MT--PROCEDURE put (item : IN SYSTEM.BYTE) ; -- TeleLie-ADA flags this as an --&MT -- illegel redeclaration! --&MT PROCEDURE put_byte (item : IN SYSTEM.BYTE) ; -- so... use this PROCEDURE put_byte (item : IN bit_count_8_type) ; PROCEDURE put_line (item : IN CHARACTER) ; PROCEDURE put_line (item : IN STRING) ; PROCEDURE put_line (item : IN bit_count_16_type) ; --&MT--PROCEDURE put_line (item : IN SYSTEM.BYTE) ; -- as above... PROCEDURE put_line_byte (item : IN bit_count_8_type) ; PROCEDURE open_debug_disk_file ; PROCEDURE close_debug_disk_file ; FUNCTION debug_disk_file_is_open RETURN BOOLEAN ; -- user could store existing destination, set his own temporary one, and -- restore the origional destination at any point to redirect debug info. -- NOTE : ATTEMPTING TO WRITE TO THE DISK FILE WHEN IT IS NOT OPEN IS ERRONEOUS. TYPE debug_destination_type IS (none, crt_only, debug_disk_file_only, crt_and_disk) ; destination : debug_destination_type := none ; END debug_io ; -- File : debugio Author : Mike Thomas -- 5/22/85 8:10 AM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:15 PM : mods for telesoft wicat WITH TEXT_IO ; USE TEXT_IO ; PACKAGE BODY debug_io IS -- **************************************************************************** -- -- It would be nice to revamp this package and use generics when they are -- supported by the compiler. Also could add enumerated type I/O routines. -- If input routines are needed, they could be added. -- **************************************************************************** debug_filename : CONSTANT STRING(1..13) := "DEBUGFILE.TXT" ; debug_output_file : TEXT_IO.FILE_TYPE ; output_file : TEXT_IO.FILE_MODE := TEXT_IO.OUT_FILE ; the_debug_disk_file_is_open : BOOLEAN := FALSE ; --&MT next line not used for TeleSoft --&MT PACKAGE integer_io IS NEW TEXT_IO.INTEGER_IO(bit_count_16_type) ; PROCEDURE screening_put (item : IN CHARACTER) IS ------------- BEGIN IF item = ASCII.CR THEN TEXT_IO.PUT("<CR>") ; -- display logical cr so won't mess up printer ELSE TEXT_IO.PUT(item) ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.SCR_PUT(C)") ; RAISE ; END screening_put ; PROCEDURE screening_put ------------- (debug_file : IN TEXT_IO.FILE_TYPE ; item : IN CHARACTER) IS BEGIN IF item = ASCII.CR THEN TEXT_IO.PUT(debug_file, "<CR>") ; -- display logical cr so won't ELSE TEXT_IO.PUT(debug_file, item) ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.SCR_PUT(F,C)") ; RAISE ; END screening_put ; PROCEDURE put (item : IN CHARACTER) IS BEGIN CASE destination IS WHEN crt_only => screening_put(item) ; WHEN debug_disk_file_only => screening_put(debug_output_file, item) ; WHEN crt_and_disk => screening_put(item) ; screening_put(debug_output_file, item) ; WHEN none => NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(C)") ; RAISE ; END put ; PROCEDURE put (item : IN STRING) IS buf : STRING (1..4*item'length) ;-- arbitrary length(allow for "expansion") --&MT buf_ptr : bit_count_32_type RANGE 0..4*item'length := 0 ; buf_ptr : bit_count_16_type RANGE 0..4*item'length := 0 ; BEGIN -- Calls to text_io are expensive, do processing here to reduce calls -- by printing strings and not individual characters. IF destination = none THEN RETURN ; END IF ; FOR index IN item'RANGE LOOP -- check for printer control char IF item(index) = ASCII.CR THEN -- replace ASCII.CR with "<CR>" buf((buf_ptr + 1)..(buf_ptr + 4)) := "<CR>" ; buf_ptr := buf_ptr + 4 ; ELSE buf_ptr := buf_ptr + 1 ; buf(buf_ptr) := item(index) ; END IF ; END LOOP ; IF buf_ptr > 0 THEN DECLARE -- handle strings > 132 so text_io does not get constraint error --&MT start : bit_count_32_type := 1 ; --&MT stop : bit_count_32_type := 79 ; start : bit_count_16_type := 1 ; stop : bit_count_16_type := 79 ; BEGIN LOOP IF stop > buf_ptr THEN CASE destination IS WHEN crt_only => TEXT_IO.PUT(buf(start..buf_ptr)) ; WHEN debug_disk_file_only => TEXT_IO.PUT(debug_output_file, buf(start..buf_ptr)) ; WHEN crt_and_disk => TEXT_IO.PUT(buf(start..buf_ptr)) ; TEXT_IO.PUT(debug_output_file, buf(start..buf_ptr)) ; WHEN none => NULL ; END CASE ; EXIT ; ELSE CASE destination IS WHEN crt_only => TEXT_IO.PUT_LINE(buf(start..stop)) ; WHEN debug_disk_file_only => TEXT_IO.PUT_LINE(debug_output_file, buf(start..stop)) ; WHEN crt_and_disk => TEXT_IO.PUT_LINE(buf(start..stop)) ; TEXT_IO.PUT_LINE(debug_output_file, buf(start..stop)) ; WHEN none => NULL ; END CASE ; start := start + 79; stop := stop + 79 ; END IF ; -- < 79 characters ? END LOOP ; END ; -- declare END IF ; -- buf_ptr > 0 EXCEPTION WHEN OTHERS => TEXT_IO.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(S)") ; RAISE ; END put ; PROCEDURE put (item : IN bit_count_16_type) IS BEGIN CASE destination IS WHEN crt_only => INTEGER_IO.PUT(item) ; WHEN debug_disk_file_only => INTEGER_IO.PUT(debug_output_file, item) ; WHEN crt_and_disk => INTEGER_IO.PUT(item) ; INTEGER_IO.PUT(debug_output_file, item) ; WHEN none => NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(I)") ; RAISE ; END put ; PROCEDURE put_byte (item : IN bit_count_8_type) IS BEGIN debug_io.put('<') ; debug_io.put(bit_count_16_type(item)) ; debug_io.put('>') ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(B)") ; RAISE ; END put_byte ; PROCEDURE put_line (item : IN CHARACTER) IS BEGIN debug_io.put(item) ; CASE destination IS WHEN crt_only => TEXT_IO.NEW_LINE ; WHEN debug_disk_file_only => TEXT_IO.NEW_LINE(debug_output_file) ; WHEN crt_and_disk => TEXT_IO.NEW_LINE ; TEXT_IO.NEW_LINE(debug_output_file) ; WHEN none => NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(C)") ; RAISE ; END put_line ; PROCEDURE put_line (item : IN STRING) IS BEGIN IF destination = none THEN RETURN ; END IF ; debug_io.put(item) ; CASE destination IS WHEN crt_only => TEXT_IO.NEW_LINE ; WHEN debug_disk_file_only => TEXT_IO.NEW_LINE(debug_output_file) ; WHEN crt_and_disk => TEXT_IO.NEW_LINE ; TEXT_IO.NEW_LINE(debug_output_file) ; WHEN none => NULL ; END CASE ; EXCEPTION WHEN OTHERS => TEXT_IO.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(S)") ; RAISE ; END put_line ; PROCEDURE put_line (item : IN bit_count_16_type) IS BEGIN CASE destination IS WHEN crt_only => INTEGER_IO.PUT(item) ; TEXT_IO.NEW_LINE ; WHEN debug_disk_file_only => INTEGER_IO.PUT(debug_output_file, item) ; TEXT_IO.NEW_LINE(debug_output_file) ; WHEN crt_and_disk => INTEGER_IO.PUT(item) ; INTEGER_IO.PUT(debug_output_file, item) ; TEXT_IO.NEW_LINE ; TEXT_IO.NEW_LINE(debug_output_file) ; WHEN none => NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(I)") ; RAISE ; END put_line ; PROCEDURE put_line_byte (item : IN bit_count_8_type) IS BEGIN debug_io.put('<') ; debug_io.put(bit_count_16_type(item)) ; debug_io.put_line('>') ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(B)") ; RAISE ; END put_line_byte ; PROCEDURE open_debug_disk_file IS BEGIN TEXT_IO.CREATE (debug_output_file, output_file, debug_filename) ; the_debug_disk_file_is_open := TRUE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.OPEN_DDF") ; RAISE ; END open_debug_disk_file ; PROCEDURE close_debug_disk_file IS BEGIN TEXT_IO.CLOSE(debug_output_file) ; the_debug_disk_file_is_open := FALSE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.CLOSE_DDF") ; RAISE ; END close_debug_disk_file ; FUNCTION debug_disk_file_is_open RETURN BOOLEAN IS BEGIN RETURN the_debug_disk_file_is_open ; END debug_disk_file_is_open ; BEGIN -- package body NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN debugio instantiation") ; RAISE ; END debug_io ; --:::::::::::::: --idebugso.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01209-100(-) -- E-Systems, Inc. August 07, 1985 -- -- idebugso.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : idebugso -- 5/23/85 11:55 AM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:21 PM : mods for telesoft for wicat -- INTERACTIVE DEBUG STATE OUTPUT FOR TN TEST/DEBUG WITH user_data ; USE user_data ; PACKAGE I_debug_state_output IS PROCEDURE print_ppl_trans_buffers (ucb : IN control_block_type) ; PROCEDURE print_telnet_option_tables (ucb : IN control_block_type) ; PROCEDURE print_user_control_block (ucb : IN control_block_type) ; PROCEDURE dump_all (ucb : IN control_block_type) ; -- print_ppl_trans_buffers ; -- print_telnet_option_tables ; -- print_user_control_block ; END I_debug_state_output ; -- spec -- 5/23/85 11:59 AM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:21 PM : mods for telesoft for wicat -- INTERACTIVE DEBUG STATE OUTPUT FOR TN TEST/DEBUG WITH SYSTEM ; -- access ascii characters WITH debug_io ; -- writes info to a debug file and/or the CRT. PACKAGE BODY I_debug_state_output IS SUBTYPE bit_count_32_type IS LONG_INTEGER ; --&MT SUBTYPE bit_count_32_type IS INTEGER ; SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; PROCEDURE print_ppl_trans_buffers (ucb : IN control_block_type) IS BEGIN debug_io.put_line(' ') ; debug_io.put_line("PPL TRANSPORT LEVEL BUFFERS.") ; debug_io.put_line("----------------------------") ; DECLARE in_buf : trans_to_telnet_messages_record RENAMES ucb.trans_buffers.trans_to_telnet_messages ; head : trans_to_telnet_msg_buf_ptr_type := in_buf.buf_head ; tail : trans_to_telnet_msg_buf_ptr_type := in_buf.buf_tail ; --&MT buf_length : CONSTANT bit_count_32_type := --&MT bit_count_32_type(trans_to_telnet_msg_buffer_length) ; buf_length : CONSTANT bit_count_16_type := bit_count_16_type(trans_to_telnet_msg_buffer_length) ; out_buf : STRING(1..buf_length) ; --&MT out_ptr : bit_count_32_type RANGE 0..buf_length := 0 ; out_ptr : bit_count_16_type RANGE 0..buf_length := 0 ; char_byte : bit_count_8_type ; BEGIN debug_io.put_line(' ') ; debug_io.put_line("TRANS TO TELNET MESSAGE BUFFER") ; debug_io.put("head=") ; debug_io.put(head) ; debug_io.put(" tail=") ; debug_io.put_line(tail) ; WHILE (head + 1) MOD bit_count_16_type(buf_length) /= tail LOOP head := (head + 1) MOD bit_count_16_type(buf_length) ; char_byte := in_buf.buffer(head) ; IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#) AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN out_ptr := out_ptr + 1 ; out_buf(out_ptr) := CHARACTER'VAL(char_byte) ; ELSE debug_io.put(out_buf(1..out_ptr)) ; out_ptr := 0 ; debug_io.put('<') ; debug_io.put_byte(char_byte) ; debug_io.put('>') ; END IF ; END LOOP ; debug_io.put_line(out_buf(1..out_ptr)) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.TR TO TN MSG BUF") ; RAISE ; END ; DECLARE in_buf : trans_to_telnet_data_record RENAMES ucb.trans_buffers.trans_to_telnet_data ; head : trans_to_telnet_data_buf_ptr_type := in_buf.buf_head ; tail : trans_to_telnet_data_buf_ptr_type := in_buf.buf_tail ; --&MT buf_length : CONSTANT bit_count_32_type := --&MT bit_count_32_type(trans_to_telnet_data_buffer_length) ; buf_length : CONSTANT bit_count_16_type := bit_count_16_type(trans_to_telnet_data_buffer_length) ; out_buf : STRING(1..buf_length) ; --&MT out_ptr : bit_count_32_type RANGE 0..buf_length := 0 ; out_ptr : bit_count_16_type RANGE 0..buf_length := 0 ; char_byte : bit_count_8_type ; BEGIN debug_io.put_line(' ') ; debug_io.put_line("TRANS TO TELNET DATA BUFFER") ; debug_io.put("head=") ; debug_io.put(head) ; debug_io.put(" tail=") ; debug_io.put_line(tail) ; WHILE (head + 1) MOD bit_count_16_type(buf_length) /= tail LOOP head := (head + 1) MOD bit_count_16_type(buf_length) ; char_byte := in_buf.buffer(head) ; IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#) AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN -- printable out_ptr := out_ptr + 1 ; out_buf(out_ptr) := CHARACTER'VAL(char_byte) ; ELSE debug_io.put(out_buf(1..out_ptr)) ; out_ptr := 0 ; debug_io.put('<') ; debug_io.put_byte(char_byte) ; debug_io.put('>') ; END IF ; END LOOP ; debug_io.put_line(out_buf(1..out_ptr)) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.TR TO TN DATA BUF") ; RAISE ; END ; END print_ppl_trans_buffers ; PROCEDURE print_telnet_option_tables (ucb : IN control_block_type) IS ot : option_tables_type RENAMES ucb.option_tables ; PROCEDURE print_items_in_table -------------------- (table : IN user_data.option_table_type) IS BEGIN FOR index IN 1..table.number_of_items LOOP CASE table.option(index) IS WHEN user_data.echo => debug_io.put(" echo ") ; WHEN user_data.suppress_ga => debug_io.put(" suppress_ga ") ; WHEN OTHERS => debug_io.put("undefined item") ; END CASE ; END LOOP ; END print_items_in_table ; BEGIN debug_io.put_line(' ') ; debug_io.put_line("TELNET OPTION TABLES") ; debug_io.put_line("--------------------") ; debug_io.put_line(' ') ; debug_io.put("local options desired : ") ; print_items_in_table(ot.local_options_desired) ; debug_io.put_line(' ') ; debug_io.put_line(' ') ; debug_io.put("remote options desired : ") ; print_items_in_table(ot.remote_options_desired) ; debug_io.put_line(' ') ; debug_io.put_line(' ') ; debug_io.put("local options pending : ") ; print_items_in_table(ot.local_options_pending) ; debug_io.put_line(' ') ; debug_io.put_line(' ') ; debug_io.put("remote options pending : ") ; print_items_in_table(ot.remote_options_pending) ; debug_io.put_line(' ') ; debug_io.put_line(' ') ; debug_io.put("local options in effect : ") ; print_items_in_table(ot.local_options_in_effect) ; debug_io.put_line(' ') ; debug_io.put_line(' ') ; debug_io.put("remote options in effect : ") ; print_items_in_table(ot.remote_options_in_effect) ; debug_io.put_line(' ') ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.PRNT OPT TABS") ; RAISE ; END print_telnet_option_tables ; PROCEDURE print_user_control_block (ucb : IN control_block_type) IS BEGIN debug_io.put_line(' ') ; debug_io.put_line("USER CONTROL BLOCK.") ; debug_io.put_line("------------------") ; debug_io.put_line(' ') ; DECLARE -- partial command buffer length : CONSTANT partial_command_buf_length := ucb.partial_command_buffer.length ; --&MT max_buf_length : CONSTANT bit_count_32_type := --&MT bit_count_32_type(max_cmd_length) ; max_buf_length : CONSTANT bit_count_16_type := bit_count_16_type(max_cmd_length) ; out_buf : STRING(1..max_buf_length) ; --&MT out_ptr : bit_count_32_type RANGE 0..max_buf_length := 0 ; out_ptr : bit_count_16_type RANGE 0..max_buf_length := 0 ; char_byte : bit_count_8_type ; BEGIN debug_io.put_line("APL partial command buffer.") ; debug_io.put("length=") ; debug_io.put_line(length) ; FOR index IN 1..length LOOP char_byte := ucb.partial_command_buffer.buffer(index) ; IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#) AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN -- printable out_ptr := out_ptr + 1 ; out_buf(out_ptr) := CHARACTER'VAL(char_byte) ; ELSE -- print ascii code # debug_io.put(out_buf(1..out_ptr)) ; out_ptr := 0 ; debug_io.put('<') ; debug_io.put_byte(char_byte) ; debug_io.put('>') ; END IF ; END LOOP ; debug_io.put_line(out_buf(1..bit_count_16_type(length))) ; --&MT debug_io.put_line(out_buf(1..bit_count_32_type(length))) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.PART_CMD_BUF") ; RAISE ; END ; DECLARE -- data buffer head : data_buf_ptr := ucb.data_buffer.buf_head ; tail : data_buf_ptr := ucb.data_buffer.buf_tail ; --&MT buf_length : CONSTANT bit_count_32_type := --&MT bit_count_32_type(data_buffer_length) ; buf_length : CONSTANT bit_count_16_type := bit_count_16_type(data_buffer_length) ; out_buf : STRING(1..buf_length) ; --&MT out_ptr : bit_count_32_type RANGE 0..buf_length := 0 ; out_ptr : bit_count_16_type RANGE 0..buf_length := 0 ; char_byte : bit_count_8_type ; BEGIN debug_io.put_line(' ') ; debug_io.put_line("APL data buffer.") ; debug_io.put("head=") ; debug_io.put(head) ; debug_io.put(" tail=") ; debug_io.put_line(tail) ; WHILE (head + 1) MOD bit_count_16_type(buf_length) /= tail LOOP head := (head + 1) MOD bit_count_16_type(buf_length) ; char_byte := ucb.data_buffer.buffer(head) ; IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#) AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN -- printable out_ptr := out_ptr + 1 ; out_buf(out_ptr) := CHARACTER'VAL(char_byte) ; ELSE debug_io.put(out_buf(1..out_ptr)) ; out_ptr := 0 ; debug_io.put('<') ; debug_io.put_byte(char_byte) ; debug_io.put('>') ; END IF ; END LOOP ; debug_io.put_line(out_buf(1..out_ptr)) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.DATA_BUF") ; RAISE ; END ; -- state information debug_io.put_line(' ') ; debug_io.put_line("STATE INFORMATION.") ; debug_io.put_line("------------------") ; debug_io.put_line(' ') ; debug_io.put("port=") ; debug_io.put_line(ucb.port) ; debug_io.put("tl_port_number=") ; debug_io.put_line(ucb.tl_port_number) ; debug_io.put("nvt_io_state = ") ; IF ucb.nvt_io_state = IO_done THEN debug_io.put_line("io_done") ; ELSIF ucb.nvt_io_state = no_IO_done THEN debug_io.put_line("no_io_done") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("communication_state = ") ; IF ucb.communication_state = connection_established THEN debug_io.put_line("connection_established") ; ELSIF ucb.communication_state = no_connection_established THEN debug_io.put_line("no_connection_established") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("command_state = ") ; IF ucb.command_state = partial_command THEN debug_io.put_line("partial_command") ; ELSIF ucb.command_state = no_partial_command THEN debug_io.put_line("no_partial_command") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("ga_state = ") ; IF ucb.ga_state = go_ahead_sent THEN debug_io.put_line("go_ahead_sent") ; ELSIF ucb.ga_state = no_go_ahead_sent THEN debug_io.put_line("no_go_ahead_sent") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("ga_received = ") ; IF ucb.ga_received = TRUE THEN debug_io.put_line("go_ahead_received") ; ELSIF ucb.ga_received = FALSE THEN debug_io.put_line("no_go_ahead_received") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("synch_is_in_progress = ") ; IF ucb.synch_is_in_progress = TRUE THEN debug_io.put_line("synch_is_in_progress") ; ELSIF ucb.synch_is_in_progress = FALSE THEN debug_io.put_line("no_synch_is_in_progress") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("last_keybd_char_was_cmd = ") ; IF ucb.last_keybd_char_was_cmd = TRUE THEN debug_io.put_line("TRUE") ; ELSIF ucb.synch_is_in_progress = FALSE THEN debug_io.put_line("FALSE") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("rcv_data_is_urgent = ") ; IF ucb.rcv_data_is_urgent = TRUE THEN debug_io.put_line("TRUE") ; ELSIF ucb.rcv_data_is_urgent = FALSE THEN debug_io.put_line("FALSE") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; debug_io.put("last_data_char_rcv_not_cr = ") ; IF ucb.last_data_char_rcv_not_cr = TRUE THEN debug_io.put_line("TRUE") ; ELSIF ucb.last_data_char_rcv_not_cr = FALSE THEN debug_io.put_line("FALSE") ; ELSE debug_io.put_line("*UNDEFINED*") ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.PRINT UCB") ; RAISE ; END print_user_control_block ; PROCEDURE dump_all (ucb : IN control_block_type) IS BEGIN debug_io.put_line(' ') ; debug_io.put_line (".......................... dump all start ......................") ; debug_io.put_line(' ') ; print_ppl_trans_buffers(ucb) ; print_telnet_option_tables(ucb) ; print_user_control_block(ucb) ; debug_io.put_line(' ') ; debug_io.put_line ("eeeeeeeeeeeeeeeeeeeeeeeee dump all end eeeeeeeeeeeeeeeeeeeeee") ; debug_io.put_line(' ') ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.DUMP ALL") ; RAISE ; END dump_all ; BEGIN NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.TR TO TN MSG BUF") ; RAISE ; END I_debug_state_output ; --:::::::::::::: --poptngpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01210-100(-) -- E-Systems, Inc. August 07, 1985 -- -- poptngpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File poptngpac -- 5/7/85 1:50 PM : MODIFY FOR DEC ADA AUTHOR : MIKE THOMAS -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/1/85 1:28 PM : remove status variable from request calls -- 7/16/85 2:29 PM : mods for telesoft wicat WITH user_data ; USE user_data ; --&MT added this to help with handling of enumerated types WITH SYSTEM ; -- access system.byte PACKAGE option_negotiation -- specification ------------------ IS --********************* USER SPECIFICATION ******************************** -- -- This package will have routines to negotiate the transfer syntax and -- virtual resource characteristics. A procedure will negotiate initial -- options. Additionally, procedures can be called to explicitly request -- option enable or demand option disable of a particular option at any time. -- ************************************************************************** -- NOTE : This compiles OK but does not work properly during runtime. -- so get directly from user_data until on a real ADA compiler -- SUBTYPE ppl_option_type IS user_data.option_type ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; PROCEDURE request_local_option_enable -- specification --------------------------- (option : IN user_data.option_type) ; -- ************************ USER SPECIFICATION **************************** -- -- If the connection is established and the option is not already in effect, -- this procedure will negotiate for that option. If there is no connection -- established, the desirable option tables will be updated and TELNET -- PPL will try to negotiate these options at the establishment of a new -- connection. ----------------------------------------------------------------------------- PROCEDURE demand_local_option_disable -- specification --------------------------- (option : IN user_data.option_type) ; -- ************************ USER SPECIFICATION **************************** -- -- If the connection is established and the option is already in effect, -- this procedure will negotiate the cessation of that option. If there is -- no connection established, the desirable option tables will be updated -- and TELNET PPL will not try to negotiate this option at the establishment -- of a new connection. ----------------------------------------------------------------------------- PROCEDURE request_remote_option_enable -- specification ---------------------------- (option : IN user_data.option_type) ; -- ************************ USER SPECIFICATION **************************** -- -- If the connection is established and the option is not already in effect, -- this procedure will negotiate for that option. If there is no connection -- established, the desirable option tables will be updated and TELNET PPL -- will try to negotiate these options at the establishment of a new -- connection. ----------------------------------------------------------------------------- PROCEDURE demand_remote_option_disable -- specification ---------------------------- (option : IN user_data.option_type) ; -- ************************ USER SPECIFICATION **************************** -- -- If the connection is established and the option is already in effect, -- this procedure will negotiate the cessation of that option. If there is -- no connection established, the desirable option tables will be updated -- and TELNET PPL will not try to negotiate this option at the establishment -- of a new connection. ----------------------------------------------------------------------------- PROCEDURE negotiate_initial_desired_options ; -- specification --------------------------------- -- ************************ USER SPECIFICATION **************************** -- -- This procedure will use the information contained in the desirable -- options tables to negotiate options with the remote TELNET. ----------------------------------------------------------------------------- PROCEDURE remote_will_received -- specification -------------------- (option_code : IN bit_count_8_type) ; -- ************************* USER SPECIFICATION *************************** -- -- This procedure will inform the option negotiation subprograms that a -- WILL (option) was received from the remote TELNET. ------------------------------------------------------------------------- PROCEDURE remote_wont_received -- specification -------------------- (option_code : IN bit_count_8_type) ; -- ************************* USER SPECIFICATION *************************** -- -- This procedure will inform the option negotiation subprograms that a -- WONT (option) was received from the remote TELNET. ------------------------------------------------------------------------- PROCEDURE remote_do_received -- specification ------------------ (option_code : IN bit_count_8_type) ; -- ************************* USER SPECIFICATION *************************** -- -- This procedure will inform the option negotiation subprograms that a -- DO (option) was received from the remote TELNET. ------------------------------------------------------------------------- PROCEDURE remote_dont_received -- specification -------------------- (option_code : IN bit_count_8_type) ; -- ************************* USER SPECIFICATION *************************** -- -- This procedure will inform the option negotiation subprograms that a -- DONT (option) was received from the remote TELNET. ------------------------------------------------------------------------- END option_negotiation ; -- package specification -- File poptngpac -- 7-1-85 1:32 PM : remove status var from requests -- 5:46 PM : fix bug in option negotiation disable,dont,wont -- 7/16/85 2:29 PM : mods for telesoft wicat WITH debug_io ; WITH virtual_transport_level ; --&MT WITH dec_tn_tasks ;--&MT not user in telesoft PACKAGE BODY option_negotiation IS ------------------ SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; TYPE action_type IS (tn_will, tn_wont, tn_do, tn_dont) ; TYPE action_code_array_type IS ARRAY(action_type) OF bit_count_8_type ; TYPE option_code_array_type IS ARRAY(user_data.option_type) OF bit_count_8_type ; action_kind : action_type ; action_code : action_code_array_type ;-- aggregate asignment not implimented option_code : option_code_array_type ;-- during decl.(do assign in body part) echo : user_data.option_type ; -- TeleSoft-Ada can't do assign here suppress_ga : user_data.option_type ; -- ditto IAC : CONSTANT bit_count_8_type := 255 ; -- interprate as command code option_tables : user_data.option_tables_type RENAMES user_data.user_control_block.option_tables ; local_options_desired : user_data.option_table_type RENAMES option_tables.local_options_desired ; local_options_in_effect : user_data.option_table_type RENAMES option_tables.local_options_in_effect ; local_options_pending : user_data.option_table_type RENAMES option_tables.local_options_pending ; remote_options_desired : user_data.option_table_type RENAMES option_tables.remote_options_desired ; remote_options_in_effect : user_data.option_table_type RENAMES option_tables.remote_options_in_effect ; remote_options_pending : user_data.option_table_type RENAMES option_tables.remote_options_pending ; PROCEDURE store_message (message : IN STRING) IS -- (local procedure) ------------- tl_msg : user_data.trans_to_telnet_messages_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_messages ; msg_buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_msg_buffer_length ; BEGIN FOR index IN 1..message'LENGTH LOOP tl_msg.buffer(tl_msg.buf_tail) := bit_count_8_type(CHARACTER'POS(message(index))) ; tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ; END LOOP ; tl_msg.buffer(tl_msg.buf_tail) := 10 ; -- ascii.lf tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ; tl_msg.buffer(tl_msg.buf_tail) := 13 ; -- ascii.cr tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ; --&MT dec_tn_tasks.tn.go ; -- make sure message gets out --&MT (dec only) EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@ EXCEPTION IN POPTNGPAC.STORE_MESSAGE") ; RAISE ; END store_message ; PROCEDURE send_option ----------- (action : IN action_type ; option : IN user_data.option_type) IS data : virtual_transport_level.info_output_type(1..3) ; BEGIN data(1) := IAC ; data(2) := action_code(action) ; data(3) := option_code(option) ; virtual_transport_level.send_data(data, FALSE) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.send_option(o)") ; RAISE ; END send_option ; PROCEDURE send_option ----------- (action : IN action_type ; option_code : IN bit_count_8_type) IS data : virtual_transport_level.info_output_type(1..3) ; BEGIN data(1) := IAC ; data(2) := action_code(action) ; data(3) := option_code ; virtual_transport_level.send_data(data, FALSE) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.send_option(c)") ; RAISE ; END send_option ; PROCEDURE send_message ------------ (message : IN STRING) IS tl_message : virtual_transport_level.info_output_type(1..message'LENGTH) ; BEGIN FOR index IN message'RANGE LOOP -- convert to system.byte tl_message(bit_count_16_type(index)) := bit_count_8_type(CHARACTER'POS(message(index))) ; END LOOP ; virtual_transport_level.send_message(tl_message) ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.send_message") ; RAISE ; END send_message ; FUNCTION option_in_table --------------- (table : IN user_data.option_table_type ; option : IN user_data.option_type) RETURN BOOLEAN IS BEGIN FOR index IN 1..table.number_of_items LOOP IF table.option(bit_count_16_type(index)) = option THEN RETURN TRUE ; END IF ; END LOOP ; RETURN FALSE ; END option_in_table ; FUNCTION local_option_already_in_effect_or_being_negotiated -------------------------------------------------- (option : IN user_data.option_type) RETURN BOOLEAN IS BEGIN IF option_in_table(local_options_in_effect, option)THEN RETURN TRUE ;END IF ; IF option_in_table(local_options_pending, option) THEN RETURN TRUE ; END IF ; RETURN FALSE ; END local_option_already_in_effect_or_being_negotiated ; FUNCTION remote_option_already_in_effect_or_being_negotiated --------------------------------------------------- (option : IN user_data.option_type) RETURN BOOLEAN IS BEGIN IF option_in_table(remote_options_in_effect,option) THEN RETURN TRUE ;END IF; IF option_in_table(remote_options_pending, option) THEN RETURN TRUE ;END IF ; RETURN FALSE ; END remote_option_already_in_effect_or_being_negotiated ; PROCEDURE add_option_to_table -- no check for overflow or duplication ------------------- (table : IN OUT user_data.option_table_type ; option : IN user_data.option_type) IS BEGIN table.number_of_items := table.number_of_items + 1 ; table.option(table.number_of_items) := option ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.add_option_") ; RAISE ; END add_option_to_table ; PROCEDURE delete_option_from_table ------------------------ (table : IN OUT user_data.option_table_type ; option : IN user_data.option_type) IS -- dedicated to Evanne save_index : bit_count_16_type RANGE 0..user_data.number_of_options_supported := 0 ; BEGIN FOR index IN 1..table.number_of_items LOOP IF table.option(bit_count_16_type(index)) /= option THEN save_index := save_index + 1 ; table.option(save_index) := table.option(index) ; END IF ; END LOOP ; table.number_of_items := save_index ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.delete_option_") ; RAISE ; END delete_option_from_table ; PROCEDURE request_local_option_enable -- body --------------------------- (option : IN user_data.option_type) IS -- ************************ BODY SPECIFICATION **************************** -- -- If the connection is established and the option is not already in effect, -- this procedure will negotiate for that option. Otherwise, the desirable -- option tables will be updated and TELNET PPL will try to negotiate these -- options at the establishment of a new connection. ----------------------------------------------------------------------------- BEGIN IF (user_data.user_control_block.communication_state = user_data.connection_established) AND (NOT(local_option_already_in_effect_or_being_negotiated(option))) THEN action_kind := tn_will ; send_option(action_kind, option) ; add_option_to_table(local_options_pending, option) ; ELSE add_option_to_table(local_options_desired, option) ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rloe") ; RAISE ; END request_local_option_enable ; -- body PROCEDURE demand_local_option_disable -- body --------------------------- (option : IN user_data.option_type) IS -- ************************ BODY SPECIFICATION **************************** -- -- If the connection is established and the option is already in effect, -- this procedure will negotiate the cessation of that -- option. If there is no connection established, the desirable option -- tables will be updated and TELNET PPL will not try to negotiate this -- option at the establishment of a new connection. ----------------------------------------------------------------------------- BEGIN IF (user_data.user_control_block.communication_state = user_data.connection_established) AND option_in_table(local_options_in_effect, option) THEN action_kind := tn_wont ; send_option(action_kind, option) ; add_option_to_table(local_options_pending, option) ; ELSE delete_option_from_table(local_options_desired, option) ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.dlod") ; RAISE ; END demand_local_option_disable ; -- body PROCEDURE request_remote_option_enable -- body ---------------------------- (option : IN user_data.option_type) IS -- ************************ BODY SPECIFICATION **************************** -- -- If the connection is established and the option is not already in effect, -- this procedure will negotiate for that option. Otherwise, the desirable -- option tables will be updated and TELNET PPL will try to negotiate these -- options at the establishment of a new connection. ----------------------------------------------------------------------------- BEGIN IF (user_data.user_control_block.communication_state = user_data.connection_established) AND (NOT(remote_option_already_in_effect_or_being_negotiated(option))) THEN action_kind := tn_do ; send_option(action_kind, option) ; add_option_to_table(remote_options_pending, option) ; ELSE -- add to desired options table add_option_to_table(remote_options_desired, option) ; END IF ; -- not (in effect or in negotiation) EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rroe") ; RAISE ; END request_remote_option_enable ; -- body PROCEDURE demand_remote_option_disable -- body ---------------------------- (option : IN user_data.option_type) IS -- ************************ BODY SPECIFICATION **************************** -- -- If the connection is established and the option is already in effect, -- this procedure will negotiate the cessation of that -- option. If there is no connection established, the desirable option -- tables will be updated and TELNET PPL will not try to negotiate this -- option at the establishment of a new connection. ----------------------------------------------------------------------------- BEGIN IF (user_data.user_control_block.communication_state = user_data.connection_established) AND option_in_table(remote_options_in_effect, option) THEN action_kind := tn_dont ; send_option(action_kind, option) ; add_option_to_table(remote_options_pending, option) ; ELSE delete_option_from_table(remote_options_desired, option) ; END IF ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.drod") ; RAISE ; END demand_remote_option_disable ; -- body PROCEDURE negotiate_initial_desired_options -- body --------------------------------- IS -- ************************ BODY SPECIFICATION ************************** -- -- This procedure will use the information contained in the desirable -- options tables to negotiate initial options with the remote TELNET -- connection. -- -- Processing sequence... -- Check the table of remote options that are desired for the other end -- and send a DO OPTION --- through the connection for each. Check the -- table of local options desirable on this end and send a WILL OPTION --- -- through the connection for each. --------------------------------------------------------------------------- BEGIN -- negotiate initial options procedure body action_kind := tn_do ; FOR index IN 1..remote_options_desired.number_of_items LOOP request_remote_option_enable (remote_options_desired.option(index)) ; END LOOP ; action_kind := tn_will ; FOR index IN 1..local_options_desired.number_of_items LOOP request_local_option_enable(local_options_desired.option(index)) ; END LOOP ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.nido") ; RAISE ; END negotiate_initial_desired_options ; -- procedure body PROCEDURE remote_will_received -- body -------------------- (option_code : IN bit_count_8_type) IS -- ************************* BODY SPECIFICATION *************************** -- -- If the option code is not supported, send a don't for the unknown code; -- otherwize process the option in the following manner. -- If we already asked for this option(in remote_options_pending table) then -- add it to the remote_options_in_effect table and remove it from the -- remote pending options table. -- Otherwize, if the option is in the remote_options_desired table then "ack" -- it and add it to the remote_options_in_effect table. -- If the above conditions were not met, then refuse to allow the option -- and "ack" it if required(option not in remote_option_pending table) or -- simply remove it from the remote_options_pending table if no "ack" -- is neccessary. ----------------------------------------------------------------------------- BEGIN CASE option_code IS WHEN 1 => -- echo : note both sides cannot echo at once(=> loop forever) -- see RFC 857 for information on the TELNET echo option IF option_in_table(remote_options_pending, echo) AND (NOT(option_in_table(local_options_in_effect, echo))) THEN delete_option_from_table(remote_options_pending, echo) ; add_option_to_table(remote_options_in_effect, echo) ; store_message("$@$ remote echo option in effect $@$") ; ELSIF option_in_table(remote_options_desired, echo) AND (NOT(option_in_table(local_options_in_effect, echo))) THEN add_option_to_table(remote_options_in_effect, echo) ; store_message("$@$ remote echo option in effect $@$") ; action_kind := tn_do ; send_option(action_kind, echo) ; ELSE -- check if negative ack required store_message("$@$ remote echo option denied by local Telnet $@$") ; IF option_in_table(remote_options_pending, echo) THEN -- no ack delete_option_from_table(remote_options_pending, echo) ; ELSE -- send negative ack action_kind := tn_dont ; send_option(action_kind, echo) ; END IF ; END IF ; WHEN 3 => -- suppress go ahead -- see RFC 858 for information on the TELNET suppress ga option IF option_in_table(remote_options_pending, suppress_ga) THEN delete_option_from_table(remote_options_pending, suppress_ga) ; add_option_to_table(remote_options_in_effect, suppress_ga) ; store_message("$@$ remote suppress_ga option in effect $@$") ; ELSIF option_in_table(remote_options_desired, suppress_ga) THEN add_option_to_table(remote_options_in_effect, suppress_ga) ; store_message("$@$ remote suppress_ga option in effect $@$") ; action_kind := tn_do ; send_option(action_kind, suppress_ga) ; ELSE -- check if negative ack required store_message("$@$ remote suppress_ga option denied by local Telnet $@$") ; IF option_in_table(remote_options_pending, suppress_ga) THEN -- no ack delete_option_from_table(remote_options_pending, suppress_ga) ; ELSE -- send negative ack action_kind := tn_dont ; send_option(action_kind, suppress_ga) ; END IF ; END IF ; WHEN OTHERS => -- not supported, refuse offer action_kind := tn_dont ; send_option(action_kind, option_code) ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rwillr") ; RAISE ; END remote_will_received ; PROCEDURE remote_wont_received -- body -------------------- (option_code : IN bit_count_8_type) IS -- ************************* BODY SPECIFICATION *************************** -- -- If the code is suported then process as follows... -- If the option was requested remotly(item in remote_options_in_effect table -- and item not in remote_options_pending) then ack the wont with a dont. -- Remove the item from the romote_options_pending / in_effect tables ----------------------------------------------------------------------------- BEGIN CASE option_code IS WHEN 1 => -- ECHO -- see RFC 857 for information on the TELNET echo option store_message("$@$ remote echo option denied by remote $@$") ; IF (option_in_table(remote_options_in_effect, echo)) AND (NOT(option_in_table(remote_options_pending, echo))) THEN -- ack action_kind := tn_dont ; -- ack send_option(action_kind, echo) ; END IF ; delete_option_from_table(remote_options_in_effect, echo) ; delete_option_from_table(remote_options_pending, echo) ; WHEN 3 => -- SUPPRESS_GA -- see RFC 858 for information on the TELNET suppress_ga option store_message("$@$ remote suppress_ga option denied by remote $@$") ; IF option_in_table(remote_options_in_effect, suppress_ga) AND (NOT(option_in_table(remote_options_pending, suppress_ga))) THEN -- ack action_kind := tn_dont ; -- ack send_option(action_kind, suppress_ga) ; END IF ; delete_option_from_table(remote_options_in_effect, suppress_ga) ; delete_option_from_table(remote_options_pending, suppress_ga) ; WHEN OTHERS => -- not supported, refuse offer NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rwontr") ; RAISE ; END remote_wont_received ; PROCEDURE remote_do_received -- body ------------------ (option_code : IN bit_count_8_type) IS -- ************************* BODY SPECIFICATION *************************** -- -- If the option code is not supported, send a don't for the unknown code; -- otherwize process the option in the following manner. -- If we already asked for this option(in remote_options_pending table) then -- add it to the remote_options_in_effect table and remove it from the -- remote pending options table. -- Otherwize, if the option is in the remote_options_desired table then "ack" -- it and add it to the remote_options_in_effect table. -- If the above conditions were not met, then refuse to allow the option -- and "ack" it if required(option not in remote_option_pending table) or -- simply remove it from the remote_options_pending table if no "ack" -- is neccessary. ----------------------------------------------------------------------------- BEGIN CASE option_code IS WHEN 1 => -- echo : note both sides cannot echo at once(=> loop forever) -- see RFC 857 for information on the TELNET echo option IF option_in_table(local_options_pending, echo) AND (NOT(option_in_table(remote_options_in_effect, echo))) THEN delete_option_from_table(local_options_pending, echo) ; add_option_to_table(local_options_in_effect, echo) ; store_message("$@$ local echo option in effect $@$") ; ELSIF option_in_table(local_options_desired, echo) AND (NOT(option_in_table(remote_options_in_effect, echo))) THEN add_option_to_table(local_options_in_effect, echo) ; action_kind := tn_will ; send_option(action_kind, echo) ; store_message("$@$ local echo option in effect $@$") ; ELSE -- check if negative ack required store_message("$@$ local echo option denied by local telnet $@$") ; IF option_in_table(remote_options_pending, echo) THEN delete_option_from_table(local_options_pending, echo) ; ELSE -- send negative ack action_kind := tn_wont ; send_option(action_kind, echo) ; END IF ; END IF ; WHEN 3 => -- suppress_ga -- see RFC 858 for information on the TELNET supress_ga option IF option_in_table(local_options_pending, suppress_ga) THEN delete_option_from_table(local_options_pending, suppress_ga) ; add_option_to_table(local_options_in_effect, suppress_ga) ; store_message("$@$ local suppress_ga option in effect $@$") ; ELSIF option_in_table(local_options_desired, suppress_ga) THEN store_message("$@$ local suppress_ga option in effect $@$") ; add_option_to_table(local_options_in_effect, suppress_ga) ; action_kind := tn_will ; send_option(action_kind, suppress_ga) ; ELSE -- check if negative ack required store_message("$@$ local suppress_ga option denied by local telnet $@$") ; IF option_in_table(remote_options_pending, suppress_ga) THEN delete_option_from_table(local_options_pending, suppress_ga) ; ELSE -- send negative ack action_kind := tn_wont ; send_option(action_kind, suppress_ga) ; END IF ; END IF ; WHEN OTHERS => -- not supported, refuse offer action_kind := tn_wont ; send_option(action_kind, option_code) ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rdor") ; RAISE ; END remote_do_received ; PROCEDURE remote_dont_received -- body -------------------- (option_code : IN bit_count_8_type) IS -- ************************* BODY SPECIFICATION *************************** -- -- If the code is suported then process as follows... -- If the option was requested remotly(item in local_options_in_effect table -- and item not in local_options_pending) then ack the dont with a wont. -- Remove the item from the local_options_pending / in_effect tables ----------------------------------------------------------------------------- BEGIN CASE option_code IS WHEN 1 => -- echo -- see RFC 857 for information on the TELNET echo option store_message("$@$ local echo option denied by remote $@$") ; IF option_in_table(local_options_in_effect, echo) AND (NOT(option_in_table(local_options_pending, echo))) THEN -- ack action_kind := tn_wont ; -- ack send_option(action_kind, echo) ; END IF ; delete_option_from_table(local_options_in_effect, echo) ; delete_option_from_table(local_options_pending, echo) ; WHEN 3 => -- suppress_ga -- see RFC 858 for information on the TELNET suppress_ga store_message("$@$ local suppress_ga option denied by remote $@$") ; IF option_in_table(local_options_in_effect, suppress_ga) AND (NOT(option_in_table(local_options_pending, suppress_ga))) THEN -- ack action_kind := tn_wont ; -- ack send_option(action_kind, suppress_ga) ; END IF ; delete_option_from_table(local_options_in_effect, suppress_ga) ; delete_option_from_table(local_options_pending, suppress_ga) ; WHEN OTHERS => -- should not get this NULL ; END CASE ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rdontr") ; RAISE ; END remote_dont_received ; BEGIN -- option_negotiation body echo := user_data.echo ; -- TeleSoft won't init this in declaration suppress_ga := user_data.suppress_ga ; -- ditto -- packed agregates not impleminted yet -- action_code := (251, 252, 253, 254) ; -- RFC 854 page 14 -- option_code := (1) ; -- RFC 857 page 1 (code for echo) action_code(tn_will) := 251 ; action_code(tn_wont) := 252 ; action_code(tn_do) := 253 ; action_code(tn_dont) := 254 ; option_code(echo) := 1 ; option_code(suppress_ga) := 3 ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac instantiation") ; RAISE ; END option_negotiation ; -- package_body --:::::::::::::: --pvirtlpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01211-100(-) -- E-Systems, Inc. August 07, 1985 -- -- pvirtlpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- WITH with_ulp_communicate ; USE with_ulp_communicate ; WITH with_tcp_communicate ; USE with_tcp_communicate ; WITH t_tcp_globals_data_structures ; USE t_tcp_globals_data_structures ; WITH buffer_data ; USE buffer_data ; WITH user_data ; WITH SYSTEM ; USE SYSTEM ; PACKAGE virtual_transport_level IS SUBTYPE bit_count_32_type IS LONG_INTEGER ; SUBTYPE bit_count_16_type IS INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; TYPE transport_level_service_call_type IS (TL_open, TL_send, TL_receive, TL_close, TL_status, TL_abort) ; max_msg_length : CONSTANT bit_count_16_type := 256 ; TYPE message_type IS ARRAY (1..max_msg_length) OF bit_count_8_type ; TYPE info_output_type IS ARRAY (bit_count_16_type RANGE <>) OF bit_count_8_type ; SUBTYPE input_type IS bit_count_8_type ; TYPE service_call_parameters_type (service_call : transport_level_service_call_type) IS RECORD CASE service_call IS WHEN TL_send => urgent_flag : BOOLEAN ; info_length : bit_count_16_type RANGE 1..max_msg_length ; info : info_output_type(1..max_msg_length) ; WHEN TL_open => network_number : bit_count_16_type := 10 ; host_number : bit_count_16_type := 0 ; logical_host_number : bit_count_16_type := 0 ; imp_number : bit_count_16_type := 0 ; port_number : bit_count_16_type := 23 ; WHEN OTHERS => NULL ; END CASE ; END RECORD ; FUNCTION there_is_a_message RETURN BOOLEAN ; FUNCTION there_is_input RETURN BOOLEAN ; PROCEDURE get_message (message : OUT message_type ; length : OUT bit_count_16_type) ; PROCEDURE get_input (input : OUT input_type ; tcp_urgent_flag : OUT BOOLEAN) ; FUNCTION there_is_room_for_info_output RETURN BOOLEAN ; PROCEDURE send_data (data : IN info_output_type ; urgent_flag : IN BOOLEAN) ; PROCEDURE send_message (message : IN info_output_type) ; PROCEDURE convert_service_call_to_transport_level_syntax (service_call : IN transport_level_service_call_type ; parameter : IN service_call_parameters_type) ; END virtual_transport_level ; WITH debug_io ; PACKAGE BODY virtual_transport_level IS message_from_tcp : user_message ; lcn : tcb_ptr RENAMES user_data.user_control_block.lcn ; tl_data_is_urgent : BOOLEAN RENAMES user_data.user_control_block.rcv_data_is_urgent ; last_char_was_not_cr : BOOLEAN RENAMES user_data.user_control_block.last_data_char_rcv_not_cr ; lcn_record : tcb_ptr ; FUNCTION there_is_information_from_the_transport_level RETURN BOOLEAN IS message_ready : BOOLEAN ; BEGIN message_from_tcp.lcn := lcn ; wait_for_tcp_message(message_from_tcp) ; IF message_from_tcp.message_number = -1 THEN RETURN FALSE ; END IF ; RETURN TRUE ; END there_is_information_from_the_transport_level ; PROCEDURE store_message (message : IN STRING) IS tl_msg : user_data.trans_to_telnet_messages_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_messages ; msg_buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_msg_buffer_length ; BEGIN debug_io.put_line(" in pvirtlpac.store_message(s)") ; debug_io.put("message ==>") ; debug_io.put_line(message(1..message'LENGTH)) ; FOR index IN 1..message'LENGTH LOOP tl_msg.buffer(tl_msg.buf_tail) := bit_count_8_type(CHARACTER'POS(message(index))) ; tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ; END LOOP ; tl_msg.buffer(tl_msg.buf_tail) := 13 ; tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ; debug_io.put_line(" end pvirtlpac.store_message(s)") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.STORE_MESSAGE(s)") ; RAISE ; END store_message ; PROCEDURE get_and_process_information_from_the_transport_level IS PROCEDURE store_message (number : IN bit_count_32_type) IS digit : bit_count_16_type RANGE 0..9 ; num : bit_count_32_type := number ; number_string : STRING (1..20) ; num_digits : bit_count_16_type RANGE 0..19 := 0 ; BEGIN debug_io.put_line(" in pvirtlpac.store_message(i)") ; IF number > 0 THEN WHILE num > 0 LOOP debug_io.put("number=") ; debug_io.put_line(bit_count_16_type(number)) ; digit := bit_count_16_type(num - (num/bit_count_32_type(10)) * bit_count_32_type(10)) ; debug_io.put("digit=") ; debug_io.put_line(digit) ; num := num / bit_count_32_type(10) ; number_string(20 - num_digits) := CHARACTER'VAL(digit+16#30#) ; debug_io.put("digit_char =") ; debug_io.put_line(number_string(20 - num_digits)) ; num_digits := num_digits + 1 ; debug_io.put("num_digits=") ; debug_io.put_line(bit_count_16_type(num_digits)) ; END LOOP ; number_string(1..num_digits) := number_string(21-num_digits..20) ; ELSE num_digits := 1 ; number_string(1) := '0' ; END IF ; debug_io.put("number_string(1..num_digits)=") ; debug_io.put_line(number_string(1..num_digits)) ; store_message(number_string(1..num_digits)) ; debug_io.put_line(" end pvirtlpac.store_message(i)") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.STORE_MESSAGE(i)") ; RAISE ; END store_message ; PROCEDURE do_passive_open IS tcp_options : tcp_option_type ; open_parameters : open_params ; the_message_for_tcp : message ; BEGIN debug_io.put_line("in passive open routine") ; IF user_data.user_control_block.tl_port_number = 0 THEN debug_io.put_line("will attempt passive open") ; FOR index IN 1..50 LOOP tcp_options(index) := 0 ; END LOOP ; open_parameters := (2, 0,0,with_tcp_communicate.passive,0,255,lcn_record,0,0,tcp_options) ; the_message_for_tcp := (with_tcp_communicate.open, open_parameters) ; message_for_tcp(the_message_for_tcp) ; lcn := the_message_for_tcp.open_parameters.lcn ; END IF ; debug_io.put_line("end passive open") ; END do_passive_open ; BEGIN debug_io.put_line("in vir_tl get_and_process_information...") ; debug_io.put("msg #=") ; debug_io.put_line(message_from_tcp.message_number) ; CASE message_from_tcp.message_number IS WHEN 2 => store_message("connection illegal") ; WHEN 3 => store_message("connection does not exist") ; WHEN 4 => store_message("foreign socket unpsecified") ; WHEN 5 => store_message("insufficient resources") ; WHEN 6 => store_message("connection closing") ; user_data.user_control_block.communication_state := user_data.no_connection_established ; DECLARE parameter : service_call_parameters_type(tl_close) ; BEGIN convert_service_call_to_transport_level_syntax(tl_close, parameter) ; END ; WHEN 7 => store_message("performing urgent data processing") ; tl_data_is_urgent := TRUE ; WHEN 8 => store_message("connection aborted") ; user_data.reset_user_control_block ; do_passive_open ; WHEN 9 => store_message("precedence not allowed") ; WHEN 10 | 19 => DECLARE tl_data : user_data.trans_to_telnet_data_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_data ; data_buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_data_buffer_length ; char_count : bit_count_16_type := message_from_tcp.data_buffer.telnet_ptr - message_from_tcp.data_buffer.tcp_ptr ; cr : CONSTANT bit_count_8_type := 13 ; BEGIN debug_io.put_line("data msg detected") ; debug_io.put(" telnet_ptr=") ; debug_io.put(message_from_tcp.data_buffer.telnet_ptr) ; debug_io.put(" tcp_ptr :=") ; debug_io.put_line(message_from_tcp.data_buffer.tcp_ptr) ; FOR index IN 0..char_count LOOP debug_io.put(" position =") ; debug_io.put(message_from_tcp.data_buffer.telnet_ptr - index) ; debug_io.put(" char_code =") ; debug_io.put_line_byte(message_from_tcp.data_buffer.byte (message_from_tcp.data_buffer.telnet_ptr - index)) ; IF last_char_was_not_cr THEN tl_data.buffer(tl_data.buf_tail) := message_from_tcp.data_buffer.byte (message_from_tcp.data_buffer.telnet_ptr - index) ; tl_data.buf_tail := (tl_data.buf_tail + 1) MOD data_buf_length ; debug_io.put_line("stored") ; END IF ; IF message_from_tcp.data_buffer.byte (message_from_tcp.data_buffer.telnet_ptr - index) = cr THEN last_char_was_not_cr := FALSE ; ELSE last_char_was_not_cr := TRUE ; END IF ; END LOOP ; message_from_tcp.data_buffer.in_use := FALSE ; message_from_tcp.data_buffer.status := none ; buffree(message_from_tcp.data_buffer, 0) ; DECLARE packed_buffer : packed_buffer_ptr ; receive_data : receive_params ; task_message : message ; BEGIN buffget(packed_buffer,1) ; IF packed_buffer = NULL THEN debug_io.put_line("Unable to get buffer for a receive.") ; store_message("Unable to get buffer for a receive.") ; ELSE packed_buffer.in_use := TRUE ; packed_buffer.status := owner_tcp ; lcn_record := message_from_tcp.lcn ; receive_data := (lcn_record, packed_buffer, 190) ; task_message := (receive, receive_data) ; message_for_tcp(task_message) ; END IF ; END ; END ; WHEN 11 => store_message("security/compartment illegal") ; WHEN 12 => store_message("connection exists") ; WHEN 14 => debug_io.put_line("return lcn msg detected") ; lcn := message_from_tcp.lcn ; DECLARE packed_buffer : packed_buffer_ptr ; receive_data : receive_params ; task_message : message ; BEGIN buffget(packed_buffer,1) ; IF packed_buffer = NULL THEN debug_io.put_line("Unable to get buffer for a receive.") ; store_message("Unable to get buffer for a receive.") ; ELSE lcn_record := message_from_tcp.lcn ; receive_data := (lcn_record, packed_buffer, 190) ; task_message := (receive, receive_data) ; message_for_tcp(task_message) ; END IF ; END ; WHEN 15 => DECLARE listen : CONSTANT with_ulp_communicate.state_type := with_ulp_communicate.listen ; BEGIN debug_io.put_line("status msg detected") ; store_message(" ") ; store_message("status information :") ; store_message(" ") ; store_message("source port=") ; store_message(bit_count_32_type(message_from_tcp.status_params.source_port)) ; store_message("source address=") ; store_message(bit_count_32_type(message_from_tcp.status_params.source_address)) ; store_message("destination address=") ; store_message(bit_count_32_type(message_from_tcp.status_params.destination_address)) ; store_message("destination port=") ; store_message(bit_count_32_type(message_from_tcp.status_params.destination_port)) ; store_message("# of octets we can accept=") ; store_message(bit_count_32_type(message_from_tcp.status_params.local_rcv_window)) ; store_message("# of octets that can be sent=") ; store_message(bit_count_32_type(message_from_tcp.status_params.remote_rcv_window)) ; store_message("amount of data on retran q =") ; store_message(bit_count_32_type(message_from_tcp.status_params.octets_on_retransmit_queue)) ; store_message("amount of data waiting for us =") ; store_message(bit_count_32_type(message_from_tcp.status_params.data_waiting_for_ulp)) ; IF message_from_tcp.status_params.urgent_state THEN store_message("urgent state=true") ; ELSE store_message("urgent state=false") ; END IF ; store_message("precedence value=") ; store_message(bit_count_32_type(message_from_tcp.status_params.precedence)) ; store_message("user layer timeout=") ; store_message(bit_count_32_type(message_from_tcp.status_params.ulp_timeout)) ; store_message("security values=") ; FOR index IN 1..9 LOOP store_message(bit_count_32_type(message_from_tcp.status_params.security(index))) ; END LOOP ; IF message_from_tcp.status_params.status = with_ulp_communicate.connection_open THEN store_message("connection open") ; ELSE store_message("connection closed") ; END IF ; store_message("message_from_tcp.status_params TCB state is") ; CASE message_from_tcp.status_params.connection_state IS WHEN closed => store_message("closed") ; WHEN listen => store_message("listen") ; WHEN syn_sent => store_message("syn_sent") ; WHEN syn_received => store_message("syn received") ; WHEN established => store_message("established") ; WHEN fin_wait_1 => store_message("fin_wait_1") ; WHEN fin_wait_2 => store_message("fin_wait_2") ; WHEN close_wait => store_message("close_wait") ; WHEN last_ack => store_message("last_ack") ; WHEN time_wait => store_message("time_wait") ; WHEN OTHERS => store_message("closing") ; END CASE ; END ; -- DECLARE WHEN 16 => store_message("connection reset by other host") ; user_data.reset_user_control_block ; do_passive_open ; WHEN 17 => store_message("connection refused") ; WHEN 18 => store_message("connection closed") ; user_data.reset_user_control_block ; do_passive_open ; WHEN 20 => store_message("out of buffers in a lower layer") ; WHEN 21 => store_message("unable to reset") ; WHEN 22 => store_message("the ip is currently overloaded") ; WHEN 23 => debug_io.put_line("connection open msg detected") ; user_data.user_control_block.communication_state := user_data.connection_established ; debug_io.put_line ("communication_state set to connection_established") ; store_message("connection open") ; WHEN 24 => store_message("error: connection aborted due to user time out") ; user_data.reset_user_control_block ; do_passive_open ; WHEN OTHERS => debug_io.put("unknown msg # detected ==>") ; debug_io.put_line(message_from_tcp.message_number) ; END CASE ; debug_io.put_line("end vir_tl get_and_process_information...") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.GET_AND_PROC_INFO") ; RAISE ; END get_and_process_information_from_the_transport_level ; FUNCTION there_is_a_message RETURN BOOLEAN IS message : user_data.trans_to_telnet_messages_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_messages ; buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_msg_buffer_length ; BEGIN debug_io.put_line("in vir_tl there is a message") ; IF there_is_information_from_the_transport_level THEN debug_io.put_line("calling get&process because there is information") ; get_and_process_information_from_the_transport_level ; END IF ; debug_io.put_line("end vir_tl there is a message") ; RETURN (message.buf_head + 1) MOD buf_length /= message.buf_tail ; END there_is_a_message ; FUNCTION there_is_input RETURN BOOLEAN IS data : user_data.trans_to_telnet_data_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_data ; buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_msg_buffer_length ; BEGIN debug_io.put_line("in vir_tl there is input") ; IF there_is_information_from_the_transport_level THEN debug_io.put_line("call get and process") ; get_and_process_information_from_the_transport_level ; END IF ; debug_io.put_line("end vir_tl there is input") ; RETURN (data.buf_head + 1) MOD buf_length /= data.buf_tail ; END there_is_input ; PROCEDURE get_message (message : OUT message_type ; length : OUT bit_count_16_type) IS mess : user_data.trans_to_telnet_messages_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_messages ; buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_msg_buffer_length ; there_is_more : BOOLEAN := TRUE ; message_length : bit_count_16_type ; BEGIN debug_io.put_line("in get message") ; message_length := 0 ; IF there_is_a_message THEN WHILE there_is_more LOOP mess.buf_head := (mess.buf_head + 1) MOD buf_length ; IF mess.buffer(mess.buf_head) = 16#0D# THEN there_is_more := FALSE ; END IF ; message_length := message_length + 1 ; message(message_length) := mess.buffer(mess.buf_head) ; END LOOP ; END IF ; length := message_length ; debug_io.put(" at end of get message... ") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.GET_MESSAGE") ; RAISE ; END get_message ; PROCEDURE get_input (input : OUT input_type ; tcp_urgent_flag : OUT BOOLEAN) IS data : user_data.trans_to_telnet_data_record RENAMES user_data.user_control_block.trans_buffers.trans_to_telnet_data ; buf_length : CONSTANT bit_count_16_type := user_data.trans_to_telnet_data_buffer_length ; there_is_more : BOOLEAN := TRUE ; temp_input : input_type ; BEGIN debug_io.put_line("pvirtlpac.get_input begin") ; tcp_urgent_flag := tl_data_is_urgent ; IF there_is_input THEN data.buf_head := (data.buf_head + 1) MOD buf_length ; temp_input := data.buffer(data.buf_head); debug_io.put("input code =") ; debug_io.put_line_byte(temp_input) ; END IF ; input := temp_input ; debug_io.put_line("pvirtlpac.get_input end") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.GET_INPUT") ; RAISE ; END get_input ; FUNCTION there_is_room_for_info_output RETURN BOOLEAN IS BEGIN RETURN TRUE ; END there_is_room_for_info_output ; PROCEDURE send_data (data : IN info_output_type ; urgent_flag : IN BOOLEAN) IS parameter : service_call_parameters_type(TL_send) ; BEGIN debug_io.put_line("begin vir_tl.send_data") ; parameter.urgent_flag := urgent_flag ; parameter.info_length := data'LENGTH ; FOR index IN data'RANGE LOOP parameter.info(index) := data(index) ; END LOOP ; convert_service_call_to_transport_level_syntax(TL_send, parameter) ; debug_io.put_line("end vir_tl.send_data") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.SEND_DATA") ; RAISE ; END send_data ; PROCEDURE send_message (message : IN info_output_type) IS parameter : service_call_parameters_type(TL_send) ; BEGIN debug_io.put_line("begin vir_tl.send_message") ; parameter.urgent_flag := false ; parameter.info_length := message'LENGTH ; parameter.info(1..message'LENGTH) := message(1..message'LENGTH) ; convert_service_call_to_transport_level_syntax(TL_send, parameter) ; debug_io.put_line("end vir_tl.send_message") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.SEND_MESSAGE") ; RAISE ; END send_message ; PROCEDURE convert_service_call_to_transport_level_syntax (service_call : IN transport_level_service_call_type ; parameter : IN service_call_parameters_type) IS the_message_for_tcp : message ; BEGIN debug_io.put_line("begin vir_tl.convert_service call...") ; IF (service_call = tl_open) THEN debug_io.put_line("virt_tl processed open call to TCP") ; debug_io.put("network_number=") ; debug_io.put_line(parameter.network_number) ; debug_io.put("host_number=") ; debug_io.put_line(parameter.host_number) ; debug_io.put("logical_host_number=") ; debug_io.put_line(parameter.logical_host_number) ; debug_io.put("imp_number=") ; debug_io.put_line(parameter.imp_number) ; debug_io.put("port_number=") ; debug_io.put_line(parameter.port_number) ; DECLARE foreign_net_host : bit_count_32_type ; options : tcp_option_type ; open_parameters : open_params ; FUNCTION calculate_class_a_address (net, imp, host : IN bit_count_16_type) RETURN bit_count_32_type IS BEGIN RETURN bit_count_32_type(16#1000000#) * bit_count_32_type(net) + bit_count_32_type(256) * bit_count_32_type(imp) + bit_count_32_type(host) ; END calculate_class_a_address ; BEGIN user_data.user_control_block.tl_port_number := parameter.port_number ; FOR index IN 1..50 LOOP options(index) := 0 ; END LOOP ; foreign_net_host := bit_count_32_type(parameter.logical_host_number) ; lcn_record := lcn ; open_parameters := (parameter.imp_number, parameter.port_number, foreign_net_host, with_tcp_communicate.active, 0, 15, lcn_record, 0, 0, options) ; the_message_for_tcp := (with_tcp_communicate.open, open_parameters) ; message_for_tcp(the_message_for_tcp) ; lcn := the_message_for_tcp.open_parameters.lcn ; END ; ELSIF service_call = tl_send THEN debug_io.put_line("virt_tl processing send call to TCP") ; DECLARE packed_buffer : packed_buffer_ptr ; send_data : send_params ; tl_byte_count : bit_count_16_type := parameter.info_length - 1 ; tl_push_flag : CONSTANT bit_count_16_type := 1 ; tl_urgent_flag : bit_count_16_type := 0 ; tl_time_out : CONSTANT bit_count_16_type := 15 ; buffer_index : bit_count_16_type := 0 ; cr : CONSTANT bit_count_8_type := 13 ; lf : CONSTANT bit_count_8_type := 10 ; BEGIN debug_io.put_line("in pvirtlpac.send_data to tcp (actual tcp call)") ; IF parameter.info_length > 0 THEN buffget(packed_buffer,1) ; IF packed_buffer = NULL THEN store_message("out of buffers") ; ELSE IF parameter.urgent_flag THEN tl_urgent_flag := 1 ; END IF ; FOR index IN 1..parameter.info_length LOOP packed_buffer.byte(packed_buffer.telnet_ptr - buffer_index) := parameter.info(index) ; buffer_index := buffer_index + 1 ; debug_io.put("data code=") ; debug_io.put_line_byte(parameter.info(index)) ; IF parameter.info(index) = cr THEN packed_buffer.byte(packed_buffer.telnet_ptr - buffer_index) := lf ; buffer_index := buffer_index + 1 ; debug_io.put("data code=") ; debug_io.put_byte(lf) ; debug_io.put_line(" lf inserted") ; END IF ; END LOOP ; lcn_record := lcn ; tl_byte_count := buffer_index - 1 ; packed_buffer.telnet_ptr := packed_buffer.telnet_ptr - tl_byte_count; packed_buffer.tcp_ptr := packed_buffer.telnet_ptr - 1 ; debug_io.put("tl_byte_count=") ; debug_io.put_line(tl_byte_count) ; debug_io.put("telnet_ptr=") ; debug_io.put_line(packed_buffer.telnet_ptr) ; debug_io.put("tcp_ptr=") ; debug_io.put_line(packed_buffer.tcp_ptr) ; send_data := (lcn_record, packed_buffer, tl_byte_count, tl_push_flag, tl_urgent_flag, tl_time_out) ; the_message_for_tcp := (send, send_data) ; message_for_tcp(the_message_for_tcp) ; END IF ; END IF ; END ; debug_io.put_line("end virt_tl processing send call to TCP") ; ELSIF service_call = tl_receive THEN debug_io.put_line("virt_tl processed receive call to TCP") ; ELSIF service_call = tl_close THEN debug_io.put_line("virt_tl processing close call to TCP") ; DECLARE close_params : abort_close_params ; BEGIN lcn_record := lcn ; close_params := (lcn => lcn_record) ; the_message_for_tcp := (with_tcp_communicate.close, close_params) ; message_for_tcp(the_message_for_tcp) ; END ; debug_io.put_line("communication_state is no_connection_established") ; ELSIF service_call = tl_status THEN debug_io.put_line("virt_tl processing status call to TCP") ; DECLARE status_data : status_params ; BEGIN lcn_record := lcn ; status_data := (lcn => lcn_record) ; the_message_for_tcp := (with_tcp_communicate.status, status_data) ; message_for_tcp(the_message_for_tcp) ; END ; ELSIF service_call = tl_abort THEN debug_io.put_line("virt_tl processing abort call to TCP") ; DECLARE abort_params : abort_close_params ; BEGIN lcn_record := lcn ; abort_params := (lcn => lcn_record) ; the_message_for_tcp := (with_tcp_communicate.abor_t, abort_params) ; message_for_tcp(the_message_for_tcp) ; END ; ELSE debug_io.put_line("unrecognized service call") ; END IF ; debug_io.put_line("end of convt serv call to tl syntax") ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.CONVERT...") ; RAISE ; END convert_service_call_to_transport_level_syntax ; BEGIN NULL ; EXCEPTION WHEN OTHERS => DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.INSTAINTIATION") ; RAISE ; END virtual_transport_level ; --:::::::::::::: --pvirtmpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01212-100(-) -- E-Systems, Inc. August 07, 1985 -- -- pvirtmpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File pvirtmpac AUTHOR : Paul Higgins -- 5/4/85 2:09 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:45 PM : mods for telesoft for wicat WITH SYSTEM ; -- to access system.byte PACKAGE virtual_terminal -- specification ---------------- IS --********************** USER SPECIFICATION ******************************* -- -- This package implements the interface between telnet and the process -- using telnet. The interface is on a character by character basis and -- is buffered. The "user process" is referred to as the NVT (network -- virtual terminal) and could be an applications process (FTP,SMTP,etc) -- or a terminal-handler. -- ------------------------- data specifications ----------------------------- SUBTYPE bit_count_32_type IS LONG_INTEGER ; --&MT SUBTYPE bit_count_32_type IS INTEGER ; SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; SUBTYPE port_number IS bit_count_16_type ; --------------------- procedure specifications ---------------------------- --- telnet's side of the interface: FUNCTION there_are_characters_in_keyboard_buffer (I : port_number) --------------------------------------- RETURN BOOLEAN ; -- *********************** USER SPECIFICATION ************************* -- -- This function returns true if there are unprocessed characters in the -- NVT keyboard buffer. ------------------------------------------------------------------------- PROCEDURE get_next_character_from_keyboard_buffer --------------------------------------- (I : IN port_number; char : OUT bit_count_8_type) ; -- *********************** USER SPECIFICATION ************************* -- -- This procedure will return the next unprocessed character from the -- NVT keyboard buffer. ------------------------------------------------------------------------- FUNCTION there_is_room_in_the_printer_buffer (I : port_number) ----------------------------------- RETURN BOOLEAN ; -- *********************** USER SPECIFICATION ************************* -- -- This function returns true if there is room for a character in the -- NVT printer buffer. ------------------------------------------------------------------------- PROCEDURE output_character_to_NVT_printer ------------------------------- (I : IN port_number; char : IN bit_count_8_type); -- *********************** USER SPECIFICATION ************************* -- -- This procedure will output a character to the NVT printer buffer. -- If there is no room in the buffer the character will be lost. -- It is the caller's responsibility to make sure there is room in the -- buffer. ------------------------------------------------------------------------- --- nvt's side of the interface FUNCTION there_are_characters_in_printer_buffer (I : port_number) --------------------------------------- RETURN BOOLEAN ; -- *********************** USER SPECIFICATION ************************* -- -- This function returns true if there are unprocessed characters in the -- NVT printer buffer. ------------------------------------------------------------------------- PROCEDURE get_next_character_from_telnet ------------------------------ (I : port_number; char : OUT bit_count_8_type) ; -- *********************** USER SPECIFICATION ************************* -- -- This procedure will return the next unprocessed character from the -- NVT printer buffer. ------------------------------------------------------------------------- FUNCTION there_is_room_in_the_keyboard_buffer (I : port_number) ----------------------------------- RETURN BOOLEAN ; -- *********************** USER SPECIFICATION ************************* -- -- This function returns true if there is room for a character in the -- NVT keyboard buffer. ------------------------------------------------------------------------- PROCEDURE send_char_to_telnet ------------------- (I : IN port_number; char : IN bit_count_8_type); -- *********************** USER SPECIFICATION ************************* -- -- If there is no room in the buffer the character will be lost. -- It is the caller's responsibility to make sure there is room in the -- buffer. ------------------------------------------------------------------------- END virtual_terminal ; -- File pvirtmpac AUTHOR : Paul Higgins -- 5/4/85 2:09 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:45 PM : mods for telesoft for wicat with text_io; use text_io ; PACKAGE BODY virtual_terminal IS ---------------- -- ************************* BODY SPECIFICATION ***************************** -- -- This package manages buffers which are tied to the process/user terminal -- "I/O" device. For example, keyboard input is stored in the keyboard_ -- input_buffer. Then, the Presentation Protocol Layer can retrieve -- characters from that buffer and pass them back to the Application Protocol -- Layer when that layer asks for the characters. Similar processing -- occurs for the printer_output_buffer. The APL could ask the PPL to send -- a character out to the NVT_printer; the PPL would put the character into -- the printer_output_buffer and this character would eventually be -- "printed" on the nvt printer. Also procedures exist to store and retrieve -- these buffers in their entirety. -- -- **************************************************************************** -- the buffers buffer_length : CONSTANT bit_count_16_type := 256 ; -- arbitrary SUBTYPE buf_ptr IS bit_count_16_type RANGE 0..buffer_length ; TYPE buffer_type IS ARRAY (0..buffer_length-1) OF bit_count_8_type ; -- keyboard input buffer TYPE keyboard_input_buffer_record IS RECORD buffer : buffer_type ; in_ptr : buf_ptr := 0 ; out_ptr : buf_ptr := 0 ; END RECORD ; -- printer output buffer TYPE printer_output_buffer_record IS RECORD buffer : buffer_type ; in_ptr : buf_ptr := 0 ; out_ptr : buf_ptr := 0 ; END RECORD ; TYPE nvt_ppl_buffers_type IS RECORD keyboard_buffer : keyboard_input_buffer_record ; printer_buffer : printer_output_buffer_record ; END RECORD ; number_of_devices : CONSTANT port_number := 1 ; io_buffer : ARRAY (1..number_of_devices) OF nvt_ppl_buffers_type ; -- Note that only one task is implemented. This should be a task type, -- and an array of them should be defined (one for each device). -- This could not be done by TS for now... TASK inbuf IS ENTRY kbd_char_rdy (device : IN port_number; rdy : OUT BOOLEAN ) ; ENTRY get_kbd_char (device : IN port_number; ch : OUT bit_count_8_type) ; ENTRY put_kbd_char (device : IN port_number; ch : IN bit_count_8_type) ; ENTRY get_printer_char (device : IN port_number; ch : OUT bit_count_8_type) ; ENTRY put_printer_char (device : IN port_number; ch : IN bit_count_8_type) ; ENTRY printer_char_rdy (device : IN port_number; rdy : OUT BOOLEAN ) ; END ; TASK BODY inbuf IS BEGIN LOOP SELECT ACCEPT kbd_char_rdy (device : IN port_number; rdy : OUT BOOLEAN ) DO rdy := io_buffer(device).keyboard_buffer.in_ptr /= io_buffer(device).keyboard_buffer.out_ptr ; END ; OR WHEN io_buffer(1).keyboard_buffer.in_ptr /= io_buffer(1).keyboard_buffer.out_ptr => ACCEPT get_kbd_char (device : IN port_number; ch : OUT bit_count_8_type) DO ch := io_buffer(device).keyboard_buffer.buffer (io_buffer(device).keyboard_buffer.out_ptr) ; io_buffer(device).keyboard_buffer.out_ptr := (io_buffer(device).keyboard_buffer.out_ptr + 1) mod buffer_length ; END ; OR ACCEPT put_kbd_char (device : IN port_number; ch : IN bit_count_8_type) DO IF io_buffer(device).keyboard_buffer.out_ptr /= (io_buffer(device).keyboard_buffer.in_ptr + 1) mod buffer_length THEN io_buffer(device).keyboard_buffer.buffer (io_buffer(device).keyboard_buffer.in_ptr) := ch ; io_buffer(device).keyboard_buffer.in_ptr := (io_buffer(device).keyboard_buffer.in_ptr + 1) mod buffer_length ; END IF ; END ; OR WHEN io_buffer(1).printer_buffer.in_ptr /= io_buffer(1).printer_buffer.out_ptr => ACCEPT get_printer_char(device : IN port_number; ch : OUT bit_count_8_type) DO ch := io_buffer(device).printer_buffer.buffer (io_buffer(device).printer_buffer.out_ptr) ; io_buffer(device).printer_buffer.out_ptr := (io_buffer(device).printer_buffer.out_ptr + 1) mod buffer_length ; END ; OR ACCEPT put_printer_char(device : IN port_number; ch : IN bit_count_8_type) DO IF io_buffer(device).printer_buffer.out_ptr /= (io_buffer(device).printer_buffer.in_ptr + 1) mod buffer_length THEN io_buffer(device).printer_buffer.buffer (io_buffer(device).printer_buffer.in_ptr) := ch ; io_buffer(device).printer_buffer.in_ptr := (io_buffer(device).printer_buffer.in_ptr + 1) mod buffer_length ; END IF ; END ; OR ACCEPT printer_char_rdy(device : IN port_number; rdy : OUT BOOLEAN ) DO rdy := io_buffer(device).printer_buffer.in_ptr /= io_buffer(device).printer_buffer.out_ptr ; END ; END SELECT ; END LOOP ; END ; FUNCTION there_are_characters_in_keyboard_buffer (I : port_number) --------------------------------------- RETURN BOOLEAN is flag : boolean ; begin inbuf.kbd_char_rdy(i, flag) ; RETURN flag ; END there_are_characters_in_keyboard_buffer ; -- body PROCEDURE get_next_character_from_keyboard_buffer --------------------------------------- (I : IN port_number; char : OUT bit_count_8_type) is BEGIN char := 0 ; -- default value inbuf.get_kbd_char(i, char) ; END get_next_character_from_keyboard_buffer ; -- body FUNCTION there_is_room_in_the_printer_buffer (I : port_number) ----------------------------------- RETURN BOOLEAN IS -- *********************** BODY SPECIFICATION ************************* -- -- This function returns true if there is room for a character in the -- NVT printer buffer. ------------------------------------------------------------------------- BEGIN RETURN TRUE ; END there_is_room_in_the_printer_buffer ; -- body PROCEDURE output_character_to_NVT_printer ------------------------------- (I : IN port_number; char : IN bit_count_8_type ) is BEGIN inbuf.put_printer_char(i,char) ; END output_character_to_NVT_printer ; -- body FUNCTION there_are_characters_in_printer_buffer (I : port_number) --------------------------------------- RETURN BOOLEAN is flag : boolean ; begin inbuf.printer_char_rdy(i, flag) ; RETURN flag ; END ; PROCEDURE get_next_character_from_telnet ------------------------------ (I : port_number; char : OUT bit_count_8_type) is begin char := 0 ; inbuf.get_printer_char(i, char) ; end ; PROCEDURE send_char_to_telnet ------------------- (I : IN port_number; char : IN bit_count_8_type ) is begin inbuf.put_kbd_char(i, char) ; end ; FUNCTION there_is_room_in_the_keyboard_buffer (I : port_number) ----------------------------------- RETURN BOOLEAN IS BEGIN RETURN TRUE ; END there_is_room_in_the_keyboard_buffer ; -- body BEGIN NULL ; END virtual_terminal ; -- package body --:::::::::::::: --telnetpac.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01213-100(-) -- E-Systems, Inc. August 07, 1985 -- -- telnetpac.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File : telnet AUTHOR : MIKE THOMAS -- 5/9/85 2:20 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:51 PM : mods for telesoft for wicat WITH user_data ; USE user_data ; WITH option_negotiation ; PACKAGE telnet_package -- specification -------------- IS -- ********************** USER SPECIFICATION ***************************** -- -- This package has the data types and data operations which are exported -- to the TELNET controller program to allow the controller to set up the -- data structure used by the TELNET procedure and the TELNET procedure -- which services a TELNET user. An array of user data structures could be -- used by the controller to serve multiple TELNET users. The -- user_information_type contains all the necessary information maintained -- for a TELNET user. The TELNET_options_supported_type lists the -- non-default options currently supported by this implementation. User -- information directly alterable by the controller are the non-standard -- TELNET options and I/O_device_characteristics. The controller -- can request to begin a non-default TELNET option, demand not to support a -- non-default option, (as well as the same request/demand for the other -- side of the TELNET connection) and set information regarding the actual -- I/O device characteristics for a particular user. These characteristics -- should be initialized prior to running the TELNET procedure, but could -- be dynamically changed if appropriate. -- -- ************************************************************************** -- *debug* make user_info_type public for test/debug *debug********** -- TYPE user_info_type IS PRIVATE ; -- user specific information SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE user_info_type IS user_data.control_block_type ; SUBTYPE telnet_options_supported_type IS -- non-default options supported user_data.option_type ; TYPE io_device_supported_type IS (process, VT100) ; SUBTYPE io_port_address_type IS bit_count_16_type ; -- arbitrary PROCEDURE telnet_request_to_do_option -- specification --------------------------- (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) ; -- ********************* USER SPECIFICATION ***************************** -- -- This procedure allows the TELNET controller to request a non-default -- TELNET option to be done locally. Used primarily to initialize -- this information prior to using the TELNET procedure, but it -- can be used to dynamically request a change in TELNET options if -- desired. If this procedure is used for a closed connection, TELNET -- will automatically try to negotiate that option upon the establishment -- of a new connection. --------------------------------------------------------------------------- PROCEDURE telnet_demand_not_to_do_option -- specification ------------------------------ (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) ; -- ********************* USER SPECIFICATION ***************************** -- -- This procedure allows the TELNET controller to demand a non-default -- TELNET option not be done locally. Used primarily to initialize -- this information prior to using the TELNET procedure, but it -- can be used to dynamically request a change in TELNET options if -- desired. --------------------------------------------------------------------------- PROCEDURE telnet_request_remote_to_do_option -- specification ---------------------------------- (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) ; -- ********************* USER SPECIFICATION ***************************** -- -- This procedure allows the TELNET controller to request a non-default -- TELNET option to be done remotely. Used primarily to initialize -- this information prior to using the TELNET procedure, but it -- can be used to dynamically request a change in TELNET options if -- desired. If this procedure is used for a closed connection, TELNET -- will automatically try to negotiate that option upon the establishment -- of a new connection. --------------------------------------------------------------------------- PROCEDURE telnet_demand_remote_not_to_do_option -- specification ------------------------------------- (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) ; -- ********************* USER SPECIFICATION ***************************** -- -- This procedure allows the TELNET controller to demand a non-default -- TELNET option not be done remotely. Used primarily to initialize -- this information prior to using the TELNET procedure, but it -- can be used to dynamically request a change in TELNET options if -- desired. --------------------------------------------------------------------------- PROCEDURE set_device_type -- specification --------------- (device_type : IN IO_device_supported_type ; user_info : IN OUT user_info_type) ; -- ********************* USER SPECIFICATION ***************************** -- -- This procedure sets the device type for use by the TELNET -- presentation protocol level to allow actual communication -- with that process or device. Used primarily to initialize -- this information prior to using the TELNET procedure, but it -- can be used to dynamically request a change if desired. --------------------------------------------------------------------------- PROCEDURE set_IO_port_address -- specification ------------------- (IO_port_address : IN IO_port_address_type ; user_info : IN OUT user_info_type) ; -- ********************* USER SPECIFICATION ***************************** -- -- This procedure sets the I/O port address for use by the TELNET -- presentation protocol level to allow actual communication -- with that process or device. Used primarily to initialize -- this information prior to using the TELNET procedure, but it -- can be used to dynamically request a change if desired. --------------------------------------------------------------------------- -- Note : Other device specific procedures may have to be added here -- as deemed appropriate baised on the characteristics of the -- of the specific devices supported and the host system. PROCEDURE telnet -- specification ------ (user_info : IN OUT user_info_type ; idle : OUT BOOLEAN) ; -- ***************** USER SPECIFICATION ***************************** -- -- This procedure implements the TELNET [1] communication protocol -- for a single user. One "pass" is made for all sources of I/O -- for a user for each call of this procedure. The controlling -- program should initialize any non-default options desired and I/O -- device characteristics prior to calling telnet. An array of -- user_info_type variables would allow the controller to process -- multiple users of TELNET. -- -- SPECIFICATION REFERENCES: -- -- [1] Network Working Group Request for Comments: 854, May 1983, -- TELNET PROTOCOL SPECIFICATION ----------------------------------------------------------------------- -- made public for test/debug -- PRIVATE -- TYPE user_info_type IS -- user specific information -- RECORD -- user_control_block : user_data.control_block_type ; -- END RECORD ; END telnet_package ; -- specification -- File telnetpac AUTHOR : MIKE THOMAS -- 5/9/85 2:35 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 6/23/85 8:57 PM : don't set ga state at top of telnet proc -- 7/1/85 2:52 PM : remove status variable from option request -- 7/16/85 2:51 PM : mods for telesoft for wicat WITH telnet_apl ; -- TELNET application protocol level USE telnet_apl ; WITH debug_io ; PACKAGE BODY telnet_package IS -------------- PROCEDURE telnet_request_to_do_option -- body --------------------------- (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) IS BEGIN -- user_data.put(user_info.user_control_block) ; -- store_user_information ; user_data.put(user_info) ; -- made public option_negotiation.request_local_option_enable(option) ; -- user_data.get(user_info.user_control_block) ; -- restore_user_information ; user_data.get(user_info) ; -- made public EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.req_l_do_opt") ; RAISE ; END telnet_request_to_do_option ; -- body PROCEDURE telnet_demand_not_to_do_option -- body ------------------------------ (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) IS BEGIN -- user_data.put(user_info.user_control_block) ; -- store_user_information ; user_data.put(user_info) ; -- made public option_negotiation.demand_local_option_disable(option) ; -- user_data.get(user_info.user_control_block) ; -- restore_user_information ; user_data.get(user_info) ; -- made public EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.dem_l_n_do_opt") ; RAISE ; END telnet_demand_not_to_do_option ; -- body PROCEDURE telnet_request_remote_to_do_option -- body ---------------------------------- (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) IS BEGIN -- user_data.put(user_info.user_control_block) ; -- store_user_information ; user_data.put(user_info) ; -- made public option_negotiation.request_remote_option_enable(option) ; -- user_data.get(user_info.user_control_block) ; -- restore_user_information ; user_data.get(user_info) ; -- made public EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.req_r_do_opt") ; RAISE ; END telnet_request_remote_to_do_option ; -- body PROCEDURE telnet_demand_remote_not_to_do_option -- body ------------------------------------- (option : IN telnet_options_supported_type ; user_info : IN OUT user_info_type) IS BEGIN -- user_data.put(user_info.user_control_block) ; -- store_user_information ; user_data.put(user_info) ; -- made public option_negotiation.demand_remote_option_disable(option) ; -- user_data.get(user_info.user_control_block) ; -- restore_user_information ; user_data.get(user_info) ; -- made public EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.dem_r_n_d_opt") ; RAISE ; END telnet_demand_remote_not_to_do_option ; PROCEDURE set_device_type -- body --------------- (device_type : IN IO_device_supported_type ; user_info : IN OUT user_info_type) IS --T B D BEGIN NULL ; END set_device_type ; -- body PROCEDURE set_IO_port_address -- body ------------------- (IO_port_address : IN IO_port_address_type ; user_info : IN OUT user_info_type) IS -- T B D BEGIN user_info.port := io_port_address ; END set_IO_port_address ; -- body PROCEDURE telnet -- body ------ (user_info : IN OUT user_info_type ; idle : OUT BOOLEAN) IS -- ***************** BODY SPECIFICATION ***************************** -- -- Processing sequence... -- -- Initialize the user information. If the NVT I/O state is I/O done, -- then set the go ahead sent state to no_go_ahead_sent and the NVT I/O -- state to no I/O done. Process any input from the NVT keyboard. Process -- any messages from the transport level. Process any transport level -- input. If APL had completed sending data to the NVT printer and had -- no queued input from the NVT keyboard for further processing -- (NVT I/O state is no-I/O-done) and the TELNET go ahead was not -- already sent then the APL must transmit the TELNET GA (go ahead) to -- the transport level [2] and mark the go ahead sent state to -- go_ahead_sent. Restore the user information. -- -- -- SPECIFICATION REFERENCES: -- -- [1] Network Working Group Request for Comments: 854, May 1983, -- TELNET PROTOCOL SPECIFICATION -- -- [2] RFC 854 : TELNET rotocol Specification -- page 5, condition 2 -- -------------------------------------------------------------------------- old_communication_state : user_data.communication_state_type ; communication_state : user_data.communication_state_type RENAMES user_data.user_control_block.communication_state ; FUNCTION time_to_send_telnet_go_ahead RETURN BOOLEAN IS ---------------------------- send_flag : BOOLEAN := FALSE ; ga_not_suppressed : BOOLEAN := TRUE ; local_options_in_effect : user_data.option_table_type RENAMES user_data.user_control_block.option_tables.local_options_in_effect ; BEGIN FOR index IN 1..local_options_in_effect.number_of_items LOOP IF local_options_in_effect.option(index) = suppress_ga THEN ga_not_suppressed := FALSE ; EXIT ; END IF ; END LOOP ; IF ga_not_suppressed AND THEN (user_control_block.NVT_IO_state = no_IO_done AND user_control_block.ga_state = no_go_ahead_sent AND user_control_block.communication_state = user_data.connection_established) THEN send_flag := TRUE ; END IF ; RETURN send_flag ; END time_to_send_telnet_go_ahead ; BEGIN -- user_data.put(user_info.user_control_block) ; --initialize_user_information user_data.put(user_info) ; -- made public -- make one "pass" for this user old_communication_state := communication_state ; user_control_block.NVT_IO_state := no_IO_done ; process_any_input_from_the_nvt_keyboard ; process_any_messages_from_the_transport_level ; process_any_input_from_the_transport_level ; IF time_to_send_telnet_go_ahead THEN transmit_telnet_go_ahead ; user_control_block.ga_state := go_ahead_sent ; END IF ; IF (old_communication_state = user_data.no_connection_established) AND THEN (communication_state = user_data.connection_established) THEN option_negotiation.negotiate_initial_desired_options ; END IF ; -- user_data.get(user_info.user_control_block) ; -- restore_user_information ; user_data.get(user_info) ; -- made public for ease of test/debug idle := user_control_block.nvt_io_state = no_io_done ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.telnet") ; RAISE ; END telnet ; -- body BEGIN -- telnet_package body NULL ; EXCEPTION WHEN OTHERS => debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac instantiation") ; RAISE ; END telnet_package ; -- body --:::::::::::::: --telserv.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01214-100(-) -- E-Systems, Inc. August 07, 1985 -- -- telserv.txt Author : Mike Thomas -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE; with SYSTEM; with SUBNET_CONTROLLER_TASK; use SUBNET_CONTROLLER_TASK; with TEXT_IO; use TEXT_IO; with BUFFER_DATA; use BUFFER_DATA; with USER_DATA; use USER_DATA; with TELNET_PACKAGE; with IOTASKS; with DEBUG_IO; use DEBUG_IO; with I_DEBUG_STATE_OUTPUT; use I_DEBUG_STATE_OUTPUT; with SUBNET_CALLS; use SUBNET_CALLS; with INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING; use INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING; with TCP_CONTROLLER_TASK; use TCP_CONTROLLER_TASK; with REAL_TIME_CLOCK_AND_DATE; use REAL_TIME_CLOCK_AND_DATE; procedure TELNET_TCP_IP is IDLE : BOOLEAN; USER_DAT_INFO : TELNET_PACKAGE.USER_INFO_TYPE; subtype BIT_COUNT_16_TYPE is INTEGER; open_parameters : with_TCP_communicate.open_params; options : with_TCP_communicate.tcp_option_type; lcn_pointer : with_TCP_communicate.LCN_TYPE; TCP_MESSAGE : WITH_TCP_COMMUNICATE.MESSAGE; begin BUFFER_DATA.INIT; --Initialize buffers START_LOCAL_CLOCK; DEBUG_IO.DESTINATION := DEBUG_IO.NONE; TELNET_PACKAGE.SET_IO_PORT_ADDRESS( 1, USER_DAT_INFO ); telnet_package.telnet_request_remote_to_do_option (suppress_ga,user_dat_info); telnet_package.telnet_request_to_do_option (suppress_ga,user_dat_info); open_parameters := ( 2, 0, 0, with_TCP_communicate.passive, 0, 255, lcn_pointer, 0, 0, options); TCP_MESSAGE := (WITH_TCP_COMMUNICATE.OPEN, OPEN_PARAMETERS); WITH_TCP_COMMUNICATE.MESSAGE_FOR_TCP( TCP_MESSAGE ); TELNET_PACKAGE.TELNET( USER_DAT_INFO, IDLE ) ; TELNET_PACKAGE.TELNET( USER_DAT_INFO, IDLE ) ; TELNET_PACKAGE.TELNET( USER_DAT_INFO, IDLE ) ; loop --TEXT_IO.PUT_LINE("CALLING SUBNET_CONTROLLER"); SUBNET_CONTROLLER; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM SUBNET"); IP_CONTROLLER; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM IP"); TCP_CONTROLLER; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM TCP"); TELNET_PACKAGE.TELNET( USER_DAT_INFO, IDLE ) ; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM TELNET"); TCP_CONTROLLER; IP_CONTROLLER; SUBNET_CONTROLLER; end loop; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR MAIN CONTROLLER"); when others => TEXT_IO.PUT_LINE("UNKNONW ERROR MAIN CONTROLLER"); end TELNET_TCP_IP; --:::::::::::::: --teluser.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01215-100(-) -- E-Systems, Inc. August 07, 1985 -- -- teluser.txt Author : Mike Thomas -- ----------------------------------------------------------------------- with SYSTEM; with SUBNET_CONTROLLER_TASK; use SUBNET_CONTROLLER_TASK; with TEXT_IO; use TEXT_IO; with BUFFER_DATA; use BUFFER_DATA; with USER_DATA; use USER_DATA; with TELNET_PACKAGE; with IOTASKS; with DEBUG_IO; use DEBUG_IO; with I_DEBUG_STATE_OUTPUT; use I_DEBUG_STATE_OUTPUT; with SUBNET_CALLS; use SUBNET_CALLS; with INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING; use INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING; with TCP_CONTROLLER_TASK; use TCP_CONTROLLER_TASK; with REAL_TIME_CLOCK_AND_DATE; use REAL_TIME_CLOCK_AND_DATE; procedure TELNET_TCP_IP is IDLE : BOOLEAN; USER_DAT_INFO : TELNET_PACKAGE.USER_INFO_TYPE; subtype BIT_COUNT_16_TYPE is INTEGER; begin DEBUG_IO.DESTINATION := DEBUG_IO.NONE; TELNET_PACKAGE.SET_IO_PORT_ADDRESS( 1, USER_DAT_INFO ); BUFFER_DATA.INIT; --Initialize buffers START_LOCAL_CLOCK; loop --TEXT_IO.PUT_LINE("CALLING SUBNET_CONTROLLER"); SUBNET_CONTROLLER; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM SUBNET"); IP_CONTROLLER; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM IP"); TCP_CONTROLLER; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM TCP"); TELNET_PACKAGE.TELNET( USER_DAT_INFO, IDLE ) ; --TEXT_IO.PUT_LINE("JUST CAME BACK FROM TELNET"); TCP_CONTROLLER; IP_CONTROLLER; SUBNET_CONTROLLER; end loop; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR MAIN CONTROLLER"); when others => TEXT_IO.PUT_LINE("UNKNONW ERROR MAIN CONTROLLER"); end TELNET_TCP_IP; --:::::::::::::: --ttyio.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00009-200 80-01216-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ttyio.txt Author : Mike Thomas -- ----------------------------------------------------------------------- -- File ttyio AUTHOR : Paul Higgins -- 5/4/85 2:09 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 7/16/85 2:56 PM : mods for telesoft for wicat package iotasks is task getchar IS --&MT PRAGMA PRIORITY(6) ; -- try to lower it to keep it from hanging end getchar; task putchar IS --&MT PRAGMA PRIORITY(8) ; -- whole telnet program end putchar; end iotasks ; -- File : ttyio Author : Paul Higgins -- 5/4/85 2:09 PM : MODIFY FOR DEC ADA -- OLD CODE (TELESOFT) MARKED AS --&MT -- 6/11/85 4:00 PM : modified for DEC Ada by Paul Higgins -- 6/14/85 3:28 PM : dec telnet tasking mod (MT) -- 7/16/85 2:56 PM : mods for telesoft for wicat with text_io ; use text_io ; with virtual_terminal; use virtual_terminal; with system ; --&MT with dec_tn_tasks ;--&MT omit this for telesoft version package body iotasks is SUBTYPE bit_count_16_type IS INTEGER ; --&MT SUBTYPE bit_count_16_type IS SHORT_INTEGER ; SUBTYPE bit_count_8_type IS SYSTEM.BYTE ; --&MT SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ; task body getchar is a_char : character ; a_var : bit_count_8_type ; cr : bit_count_8_type := 13 ; -- ASCII.CR len : integer ; a_str : string (1..255) ; begin loop IF TEXT_IO.END_OF_LINE THEN send_char_to_telnet(1,cr) ; -- text_io will not read in a ascii.cr TEXT_IO.SKIP_LINE ; -- hop past end of line ELSE text_io.get(a_char) ;--&MT telesoft version a_var := character'pos(a_char) ;--&MT telesoft version send_char_to_telnet(1,a_var) ;--&MT telesoft version --&MT vax version: --&MT text_io.get_line(a_str,len) ; --&MT for i in 1..len loop --&MT a_var := character'pos(a_str(i)) ; --&MT send_char_to_telnet(1,a_var) ; --&MT end loop ; --&MT vax --&MT send_char_to_telnet(1,cr) ; -- replace cr stripped out by text_io. END IF ; --&MT dec_tn_tasks.tn.go ;--&MT signal telnet controller that there is input end loop ; end getchar ; task body putchar is a_char : character ; a_var : bit_count_8_type ; begin loop get_next_character_from_telnet(1,a_var) ; IF bit_count_16_type(a_var) = 13 THEN -- CR ==> new line TEXT_IO.NEW_LINE ; -- text_io will send cr lf ELSE a_char := character'val(a_var) ; text_io.put(a_char) ; END IF ; end loop ; end putchar ; end iotasks ;