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 / ftp.src < prev next >

Wrap

Text File | 1988-05-03 | 366.5 KB | 9,367 lines

--:::::::::::::: --vt100_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01126-100(-) -- E-Systems, Inc. August 07, 1985 -- -- VT100_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : VT100 AUTHOR : MARK VOLPE -- 5/13/85 10:05 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/22/85 2:55 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT --&MT WITH ASCII, TEXT_IO; WITH TEXT_IO; --&MT USE ASCII, TEXT_IO; USE TEXT_IO; PACKAGE Vt100 IS PROCEDURE Reverse_video; -- -- This procedure selects a VT-100 like terminal into reverse video -- mode. -- PROCEDURE Attributes_off; -- -- This procedure returns a VT-100 like terminal to its normal mode. -- PROCEDURE Clear_screen; -- -- This procedure selects a VT-100 like terminal to clear the screen. -- PROCEDURE Bold; -- -- This procedure selects a VT-100 like terminal to turn-on the bold -- attribute. -- PROCEDURE Blink; -- -- This procedure selects a VT-100 like terminal to turn-on the -- blinking attribute -- PROCEDURE Home_position; -- -- This procedure places the cursor in the home position. -- END Vt100 ; --:::::::::::::: --vt100.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01127-100(-) -- E-Systems, Inc. August 07, 1985 -- -- VT100.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : VT100 AUTHOR : MARK VOLPE -- 5/13/85 10:05 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/22/85 2:55 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT PACKAGE BODY Vt100 IS PROCEDURE Reverse_video IS Reversevideo : STRING(1..4); BEGIN Reversevideo(1) := ASCII.ESC; Reversevideo(2..4) := "[7m"; PUT( Reversevideo ); END Reverse_video; PROCEDURE Attributes_off IS Attributesoff : STRING(1..3); BEGIN Attributesoff(1) := ASCII.ESC; Attributesoff(2..3) := "[m"; PUT( Attributesoff ); END Attributes_off; PROCEDURE Clear_screen IS Clearscreen : STRING(1..4); BEGIN Clearscreen(1) := ASCII.ESC; Clearscreen(2..4) := "[2J"; PUT( Clearscreen ); END Clear_screen; PROCEDURE Bold IS Bold_char : STRING(1..4); BEGIN Bold_char(1) := ASCII.ESC; Bold_char(2..4) := "[1m"; PUT( Bold_char ); END Bold; PROCEDURE Blink IS Blink_char : STRING(1..4); BEGIN Blink_char(1) := ASCII.ESC; Blink_char(2..4) := "[5m"; PUT( Blink_char ); END Blink; PROCEDURE Home_position IS Homeposition : STRING(1..4); BEGIN Homeposition(1) := ASCII.ESC; Homeposition(2) := 'H'; PUT( Homeposition ); END Home_position; END Vt100 ; --:::::::::::::: --mydebugio_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01122-100(-) -- E-Systems, Inc. August 07, 1985 -- -- MYDEBUGIO_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : MYDEBUGIO AUTHOR : MARK VOLPE -- 5/13/85 1:20 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH &MT -- 5/23/85 10:00 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/23/85 10:20 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINES ARE INCLUDED WHEN USING TELESOFT : --&MT WITH Vt100, TEXT_IO; --&MT USE Vt100, TEXT_IO, INTEGER_IO; --&MT THE FOLLOWING LINES ARE INCLUDED WHEN USING DEC ADA : WITH VT100, TEXT_IO; USE VT100, TEXT_IO; PACKAGE My_debug_io IS --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; PROCEDURE Put ( Output_string : IN STRING ); PROCEDURE Put_line ( Output_string : IN STRING ); PROCEDURE Put ( Output_integer : IN BIT_COUNT_16_TYPE ); PROCEDURE Put_line ( Output_integer : IN BIT_COUNT_16_TYPE ); END My_debug_io; --:::::::::::::: --mydebugio.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01123-100(-) -- E-Systems, Inc. August 07, 1985 -- -- MYDEBUGIO.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : MYDEBUGIO AUTHOR : MARK VOLPE -- 5/13/85 1:20 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE MARKED WITH &MT -- 5/23/85 1:30 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/23/85 1:50 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY My_debug_io IS --&MT THE FOLLOWING LINE IS DELETED WHEN USING TELESOFT : PACKAGE Integer_io IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PROCEDURE Put ( Output_string : IN STRING ) IS BEGIN Reverse_video; TEXT_IO.PUT ( Output_string ); Attributes_off; END PUT; PROCEDURE Put_line ( Output_string : IN STRING ) IS BEGIN Reverse_video; TEXT_IO.PUT_LINE ( Output_string ); Attributes_off; END Put_line; PROCEDURE Put ( Output_integer : IN BIT_COUNT_16_TYPE ) IS BEGIN Reverse_video; INTEGER_IO.PUT ( Output_integer ); Attributes_off; END Put; PROCEDURE Put_line ( Output_integer : IN BIT_COUNT_16_TYPE ) IS BEGIN Reverse_video; INTEGER_IO.PUT ( Output_integer ); TEXT_IO.NEW_LINE; Attributes_off; END Put_line; END My_debug_io; --:::::::::::::: --myutils_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01124-100(-) -- E-Systems, Inc. August 07, 1985 -- -- MYUTILS_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : MYUTILS AUTHOR : MARK VOLPE -- 5/13/85 2:10 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/23/85 2:35 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/23/85 2:55 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT WITH ASCII, TEXT_IO, SYSTEM, UNCHECKED_CONVERSION; --&MT INCLUDE THE FOLLOWING LINE WHEN USING DEC ADA : WITH TEXT_IO, SYSTEM, UNCHECKED_CONVERSION; PACKAGE My_utilities IS --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.BYTE; SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.UNSIGNED_BYTE; --&MT INCLUDE THE FOLLOWING LINES WHEN USING DEC ADA : PACKAGE Integer_io IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PACKAGE System_byte_io IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_8_TYPE); FUNCTION Char ( In_integer : BIT_COUNT_16_TYPE ) RETURN CHARACTER; FUNCTION Byte IS NEW Unchecked_conversion ( CHARACTER, BIT_COUNT_16_TYPE ); PROCEDURE Output_byte_to_screen ( In_byte : IN BIT_COUNT_8_TYPE := 16#00# ); PROCEDURE Sound_keyboard_bell ( Number_of_rings : IN BIT_COUNT_16_TYPE := 1 ); END My_utilities; --:::::::::::::: --myutils.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01125-100(-) -- E-Systems, Inc. August 07, 1985 -- -- MYUTILS.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : MYUTILS AUTHOR : MARK VOLPE -- 5/13/85 3:20 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/23/85 2:40 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/23/85 3:03 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY My_utilities IS FUNCTION Convert_integer_to_character IS NEW Unchecked_conversion ( BIT_COUNT_16_TYPE, CHARACTER ); FUNCTION Char ( In_integer : BIT_COUNT_16_TYPE ) RETURN CHARACTER IS Byte_string : STRING (1..2); BEGIN Byte_string(1) := Convert_integer_to_character ( In_integer ); RETURN Byte_string(1); END CHAR; PROCEDURE Output_byte_to_screen ( In_byte : IN BIT_COUNT_8_TYPE := 16#00# ) IS BEGIN IF BIT_COUNT_16_TYPE( In_byte ) < 32 THEN CASE Char( BIT_COUNT_16_TYPE(In_byte) ) IS WHEN ASCII.NUL => TEXT_IO.PUT ("<NUL>"); WHEN ASCII.SOH => TEXT_IO.PUT ("<SOH>"); WHEN ASCII.STX => TEXT_IO.PUT ("<STX>"); WHEN ASCII.ETX => TEXT_IO.PUT ("<ETX>"); WHEN ASCII.EOT => TEXT_IO.PUT ("<EOT>"); WHEN ASCII.ENQ => TEXT_IO.PUT ("<ENQ>"); WHEN ASCII.ACK => TEXT_IO.PUT ("<ACK>"); WHEN ASCII.BEL => TEXT_IO.PUT ("<BEL>"); WHEN ASCII.BS => TEXT_IO.PUT ("<BS>"); WHEN ASCII.HT => TEXT_IO.PUT ("<HT>"); WHEN ASCII.LF => TEXT_IO.PUT ("<LF>"); WHEN ASCII.VT => TEXT_IO.PUT ("<VT>"); WHEN ASCII.FF => TEXT_IO.PUT ("<FF>"); WHEN ASCII.CR => TEXT_IO.PUT ("<CR>"); TEXT_IO.NEW_LINE; WHEN ASCII.SO => TEXT_IO.PUT ("<SO>"); WHEN ASCII.SI => TEXT_IO.PUT ("<SI>"); WHEN ASCII.DLE => TEXT_IO.PUT ("<DLE>"); WHEN ASCII.DC1 => TEXT_IO.PUT ("<DC1>"); WHEN ASCII.DC2 => TEXT_IO.PUT ("<DC2>"); WHEN ASCII.DC3 => TEXT_IO.PUT ("<DC3>"); WHEN ASCII.DC4 => TEXT_IO.PUT ("<DC4>"); WHEN ASCII.NAK => TEXT_IO.PUT ("<NAK>"); WHEN ASCII.SYN => TEXT_IO.PUT ("<SYN>"); WHEN ASCII.ETB => TEXT_IO.PUT ("<ETB>"); WHEN ASCII.CAN => TEXT_IO.PUT ("<CAN>"); WHEN ASCII.EM => TEXT_IO.PUT ("<EM>"); WHEN ASCII.SUB => TEXT_IO.PUT ("<SUB>"); WHEN ASCII.ESC => TEXT_IO.PUT ("<ESC>"); WHEN ASCII.FS => TEXT_IO.PUT ("<FS>"); WHEN ASCII.GS => TEXT_IO.PUT ("<GS>"); WHEN ASCII.RS => TEXT_IO.PUT ("<RS>"); WHEN ASCII.US => TEXT_IO.PUT ("<US>"); WHEN ASCII.DEL => TEXT_IO.PUT ("<DEL>"); WHEN OTHERS => TEXT_IO.PUT ("<BAD>"); END CASE; ELSE TEXT_IO.PUT ( CHAR( BIT_COUNT_16_TYPE(IN_BYTE) )); END IF; EXCEPTION WHEN OTHERS => TEXT_IO.PUT ("<BAD>"); END Output_byte_to_screen ; PROCEDURE Sound_keyboard_bell ( Number_of_rings : IN BIT_COUNT_16_TYPE := 1 ) IS BEGIN IF Number_of_rings < 1 THEN TEXT_IO.PUT ( ASCII.NUL ); ELSE FOR Bell_count IN 1..Number_of_rings LOOP TEXT_IO.PUT ( ASCII.NUL ); END LOOP; END IF; END Sound_keyboard_bell; END My_utilities; --:::::::::::::: --ftpcmd_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01072-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPCMD_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPCMD AUTHOR : MARK VOLPE -- 5/13/85 3:40 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/23/85 3:48 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:14 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT REMOVE THE FOLLOWING LINES WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); --&MT WITH ASCII; WITH TEXT_IO; USE TEXT_IO; PACKAGE Command_types IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; -- -- The following paramters are used in interfacing to the environment -- either through the keyboard or telnet. -- Max_command_string_length : CONSTANT BIT_COUNT_16_TYPE := 132; -- RFC 765 does not specify a length; -- therefore this is arbitrary. Max_command_abbreviation_length : CONSTANT BIT_COUNT_16_TYPE := 4; -- This length is specified in the -- RFC 765 spec. p. 42 Max_command_size : CONSTANT BIT_COUNT_16_TYPE := 4; -- This length is not specified in -- the RFC 765 spec. SUBTYPE Command_string_spec IS STRING (1 ..BIT_COUNT_32_TYPE( Max_command_string_length)); -- The format of data coming from -- telnet or the keyboard is -- a string of characters. --&MT the following lines was deleted because the telesoft compiler wouldn't --&MT handle it. --&MT STRING (1 ..BIT_COUNT_16_TYPE( Max_command_string_length)); --&MT STRING (1 .. 132) ; Null_command_string : Command_string_spec; -- Holds null characters; -- necessary because telesoft -- does not support packed aggregate -- initialization --&MT THE FOLLOWING LINES SHOULD BE OMITTED WHEN USING TELESOFT PACKAGE Long_Int_IO IS NEW TEXT_IO.INTEGER_IO(bit_count_32_type); PACKAGE Int_IO IS NEW TEXT_IO.INTEGER_IO(bit_count_16_type); FUNCTION End_of_command ( Cmd_character : IN CHARACTER ) RETURN BOOLEAN; END COMMAND_TYPES; --:::::::::::::: --ftpcmd.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01073-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPCMD.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPCMD AUTHOR : MARK VOLPE -- 5/13/85 3:40 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/23/85 3:48 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:17 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY COMMAND_TYPES IS End_of_command_delimeter : CONSTANT CHARACTER := ASCII.NUL; FUNCTION End_of_command ( Cmd_character : IN CHARACTER ) RETURN BOOLEAN IS BEGIN IF Cmd_character = End_of_command_delimeter THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END End_of_command; BEGIN FOR Index IN Null_command_string'RANGE LOOP Null_command_string ( Index ) := End_of_command_delimeter; END LOOP; EXCEPTION WHEN OTHERS => TEXT_IO.NEW_LINE; TEXT_IO.PUT_LINE("***** Error in Command_TYPES *****"); RAISE; END Command_types; --:::::::::::::: --ftptypes_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01109-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTYPES_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPTYPES AUTHOR : MARK VOLPE -- 5/13/85 4:00 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/23/85 4:10 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:20 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINES SHOULD BE OMITTED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); --&MT WITH ASCII, TEXT_IO; --&MT THE FOLLOWING LINE SHOULD BE INCLUDED WHEN USING DEC ADA : WITH TEXT_IO; WITH Command_types; USE Command_types; PACKAGE Ftp_types IS ---------------------------------------------------------------------- -- -- This package contains global type declarations used throughout -- FTP. It also contains system parameters that are used by -- the server side or user side in a mutually exclusive manner. -- ---------------------------------------------------------------------- --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; Conversion_error : EXCEPTION; -- -- These are the return status' that are used in this implementation. -- They are not exhaustive and can be modified as required. -- -- TYPE RETURN_STATUS_SPEC IS -- ( SUCCESS, -- UNKNOWN_FAILURE, -- TELNET_FAILURE, -- ABORT_COMMMAND, -- TCP_FAILURE, -- USER_FAILED, -- SERVER_FAILED, -- COMMAND_VALID, -- COMMAND_INVALID ); -- These are the standard FTP commands which can be transmitted -- to other ftp sites in addition to a few 'in house' commands. -- TYPE VALID_COMMAND_SPEC IS ( CALL_COMMAND, -- establish a telnet connection CLOS_COMMAND, -- close a telnet connection EXIT_COMMAND, -- exit from ftp NOOP_COMMAND, -- send a noop to the server HELP_COMMAND, -- get help from the server STRU_COMMAND, -- set the xmit struc (f,r) TYPE_COMMAND, -- set the xmit type (a) MODE_COMMAND, -- set the xmit mode (s) PORT_COMMAND, -- set user listen port QUIT_COMMAND, -- logout from server pi USER_COMMAND, -- username for server pi PASS_COMMAND, -- password for server pi STOR_COMMAND, -- store file on server RETR_COMMAND, -- retrieve file from server REPLY_COMMAND, -- the argument is a reply INVALID_COMMAND); -- any other command string -- The following parameters specify the format for identifying a port. -- SUBTYPE Valid_port_identifier IS CHARACTER; -- RFC 765 pp. 24 TYPE Port_id IS ARRAY(1..11) OF Valid_port_identifier; -- RFC 765 pp. 23-4 -- The actual argument is 6 characters separated by 5 commas. -- The following paramters specify the format of the arguments -- This length is not specified in the RFC 765 spec. -- However, since all commands must fit on one line, -- the max argument length is max_length - command size - 1; -- Max_argument_size : CONSTANT BIT_COUNT_16_TYPE := Max_command_string_length - max_command_size - 1; --&MT Max_argument_size : CONSTANT bit_count_16_type := 127 ; SUBTYPE Argument_list_unit IS CHARACTER; -- RFC 765 p. 32 -- use a separate type to enforce data abstraction TYPE Argument_list IS ARRAY( 1 .. Max_argument_size ) OF Argument_list_unit; -- RFC 765 p. 32 -- The necessary arguments are passed as characters -- because of file names. Null_argument : Argument_list; -- This is necessary to initialize argument strings to all -- null characters since telesoft does not support -- packed aggregate initialization yet. --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING TELESOFT; PACKAGE Int_IO IS NEW TEXT_IO.INTEGER_IO(bit_count_16_type); FUNCTION End_of_argument ( Argument_element : IN Argument_list_unit ) RETURN BOOLEAN; PROCEDURE Convert_string_to_argument ( Input_string : IN STRING; Argument : OUT ARGUMENT_LIST ); PROCEDURE Convert_argument_to_string ( Argument : IN Argument_list ; Output_string : OUT String; String_length : OUT BIT_COUNT_16_TYPE ); -- -- These are the default system paramters used by a server or user pi. -- Default_file_mode : Argument_list_unit := 'S'; -- RFC 765 p 25 Default_file_structure : Argument_list_unit := 'F'; -- RFC 765 p 25 Default_file_type : Argument_list_unit := 'A'; -- RFC 765 p 24 Default_carriage_control : Argument_list_unit := 'N'; -- RFC 765 p 24 Default_port_id : Port_id; END FTP_TYPES; --:::::::::::::: --ftptypes.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01110-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTYPES.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPTYPES AUTHOR : MARK VOLPE -- 5/13/85 4:00 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/23/85 4:10 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:30 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY FTP_TYPES IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT THE FOLLOWING LINE SHOULD BE INCLUDED WHEN USING DEC ADA : PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); FUNCTION End_of_argument ( Argument_element : IN Argument_list_unit ) RETURN BOOLEAN IS BEGIN IF ARGUMENT_ELEMENT = ASCII.NUL THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END END_OF_ARGUMENT; PROCEDURE Convert_argument_to_string ( Argument : IN Argument_list ; Output_string : OUT STRING; String_length : OUT BIT_COUNT_16_TYPE) IS temp_string_length : bit_count_16_type; Argument_index : BIT_COUNT_16_TYPE := Argument_list'first; BEGIN temp_string_length := 0; FOR Index IN Output_string'RANGE LOOP IF End_of_argument ( Argument( ARGument_index ) ) THEN EXIT; ELSE temp_string_length := temp_string_length + 1; Output_string(Index) := CHARACTER'( Argument( Argument_index )); Argument_index := Argument_index + 1; END IF; END LOOP; string_length := temp_string_length; EXCEPTION WHEN OTHERS => RAISE Conversion_error; END Convert_argument_to_string; PROCEDURE Convert_string_to_argument ( Input_string : IN STRING; Argument : OUT Argument_list ) IS Argument_index : BIT_COUNT_16_TYPE := Argument'FIRST; BEGIN Argument := Null_argument; FOR Index IN Input_string'RANGE LOOP Argument(Argument_index) := Argument_list_unit'(Input_string(Index)); Argument_index := Argument_index + 1; END LOOP; EXCEPTION WHEN OTHERS => RAISE Conversion_error; END Convert_string_to_argument; BEGIN FOR Index IN Null_argument'RANGE LOOP Null_argument ( Index ) := Ascii.nul; END LOOP; DECLARE Index : bit_count_32_type := bit_count_32_type(Port_id'FIRST); --&MT Index : bit_count_16_type := bit_count_16_type(Port_id'FIRST); BEGIN Default_port_id( Index ) := Valid_port_identifier'('1'); Default_port_id( Index + 1 ) := Valid_port_identifier'(','); Default_port_id( Index + 2 ) := Valid_port_identifier'('2'); Default_port_id( Index + 3 ) := Valid_port_identifier'(','); Default_port_id( Index + 4 ) := Valid_port_identifier'('3'); Default_port_id( Index + 5 ) := Valid_port_identifier'(','); Default_port_id( Index + 6 ) := Valid_port_identifier'('4'); Default_port_id( Index + 7 ) := Valid_port_identifier'(','); Default_port_id( Index + 8 ) := Valid_port_identifier'('5'); Default_port_id( Index + 9 ) := Valid_port_identifier'(','); Default_port_id( Index + 10 ) := Valid_port_identifier'('6'); END; EXCEPTION WHEN OTHERS => TEXT_IO.NEW_LINE; TEXT_IO.PUT_LINE("***** Error in FTP_TYPES *****"); RAISE; END Ftp_types; --:::::::::::::: --ftprpl_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01084-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRPL_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPRPL AUTHOR : MARK VOLPE -- 5/14/85 9:00 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/24/85 8:30 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:50 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); --&MT WITH Ftp_types, TEXT_IO, ASCII; WITH Ftp_types, TEXT_IO; PACKAGE Reply_types IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; -- -- The following parameters specify the format of replys sent over telnet. -- Max_reply_code_length : CONSTANT BIT_COUNT_16_TYPE := 3; -- RFC 765 p. 32 Max_reply_message_length : CONSTANT BIT_COUNT_16_TYPE := Ftp_types.max_argument_size; -- RFC 765 does not specify a length -- Therefore this is arbitrary. SUBTYPE Valid_reply_code_character IS CHARACTER RANGE '0'..'9'; -- RFC 765 p. 32 TYPE Telnet_reply_code_spec IS ARRAY ( 1 .. Max_reply_code_length ) OF Valid_reply_code_character; -- RFC 765 p. 32 -- 3 digits; where a digit is a -- character in '0'..'9' SUBTYPE Message_spec IS STRING( 1 .. bit_count_32_type(Max_reply_message_length )) ; --&MT STRING(1..127) ; -- Text from reply TYPE Reply_status_spec IS ( positive_preliminary_reply_code, Positive_completion_reply_code, Positive_intermediate_reply_code, Transient_negative_completion_reply_code, Permanent_negative_completion_reply_code , Reply_code_error ); TYPE Message_type_spec IS ( Syntax, Information, Connections, Authentication, Unspecified , File_system, Message_type_error ); TYPE Reply_code_spec IS RECORD Code : Reply_status_spec; Message_type : Message_type_spec; Multiline_message : BOOLEAN; message : message_spec ; END RECORD; -- -- Codes which indicate status of reply -- Code_for_positive_preliminary_reply : CONSTANT Valid_reply_code_character := '1'; Code_for_positive_completion_reply : CONSTANT Valid_reply_code_character := '2'; Code_for_positive_intermediate_reply : CONSTANT Valid_reply_code_character := '3'; Code_for_transient_negative_completion_reply : CONSTANT Valid_reply_code_character := '4'; Code_for_permanent_negative_completion_reply : CONSTANT Valid_reply_code_character := '5'; -- -- Codes which qualify reply -- Code_for_syntax_qualifier : CONSTANT Valid_reply_code_character := '0'; Code_for_information_qualifier : CONSTANT Valid_reply_code_character := '1'; Code_for_connection_qualifier : CONSTANT Valid_reply_code_character := '2'; Code_for_authentication_qualifier : CONSTANT Valid_reply_code_character := '3'; Code_for_unspecified_qualifier : CONSTANT Valid_reply_code_character := '4'; Code_for_file_system_qualifier : CONSTANT Valid_reply_code_character := '5'; -- Null_reply_message : Message_spec; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE Long_Int_IO IS NEW TEXT_IO.INTEGER_IO (bit_count_32_type); -- -- Reply functions -- FUNCTION Positive_preliminary_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Positive_completion_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Positive_intermediate_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Transient_negative_completion_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Permanent_negative_completion_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION End_of_reply ( Reply_element : IN Valid_reply_code_character ) RETURN BOOLEAN ; FUNCTION Syntax_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Information_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Connection_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION Authentication_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; FUNCTION File_system_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN; END Reply_types; --:::::::::::::: --ftprpl.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01085-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRPL.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPRPL AUTHOR : MARK VOLPE -- 5/14/85 9:00 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/24/85 8:30 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:55 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY REPLY_TYPES IS End_of_reply_delimeter : CONSTANT CHARACTER := ASCII.NUL; FUNCTION Positive_preliminary_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.code = Positive_preliminary_reply_code THEN RETURN TRUE; ELSE RETURN FALSE; END IF; End POSITIVE_PRELIMINARY_REPLY ; FUNCTION Positive_completion_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.code = Positive_completion_reply_code THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Positive_completion_reply; FUNCTION Positive_intermediate_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.code = Positive_intermediate_reply_code THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Positive_intermediate_reply; FUNCTION Transient_negative_completion_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.code = Transient_negative_completion_reply_code THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Transient_negative_completion_reply; FUNCTION Permanent_negative_completion_reply ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.code = Permanent_negative_completion_reply_code THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Permanent_negative_completion_reply; FUNCTION End_of_reply ( Reply_element : IN Valid_reply_code_character ) RETURN BOOLEAN IS BEGIN IF Reply_element = End_of_reply_delimeter THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END End_of_reply; FUNCTION Syntax_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.message_type = Message_type_spec'( Syntax ) THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Syntax_related; FUNCTION Information_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.message_type = Message_type_spec'( Information ) THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Information_related; FUNCTION Connection_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.message_type = Message_type_spec'( Connections ) THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Connection_related; FUNCTION Authentication_related ( Reply : IN Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.message_type = Message_type_spec'( Authentication ) THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END Authentication_related; FUNCTION File_system_related ( Reply : In Reply_code_spec ) RETURN BOOLEAN IS BEGIN IF Reply.message_type = Message_type_spec'( File_system ) THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END File_system_related; BEGIN FOR Index IN Null_reply_message'RANGE LOOP Null_reply_message( Index ) := End_of_reply_delimeter; END LOOP; EXCEPTION WHEN OTHERS => TEXT_IO.PUT_LINE (" Error in reply_types initialization"); RAISE; END Reply_types; --:::::::::::::: --ftpterm_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01107-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTERM_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftpterm AUTHOR : MARK VOLPE -- 5/14/85 9:20 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/24/85 9:00 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 12:58 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); --&MT WITH TEXT_IO, ASCII; WITH TEXT_IO; WITH Command_types, Ftp_types, Reply_types; PACKAGE Ftp_terminal_driver IS ---------------------------------------------------------------------- -- -- This package contains procedures to interface to the users' terminal -- A separate I/O package was used to increase portability to systems -- where text_io is not supported. -- I/O will be slower, but very little time is spent doing I/O versus -- actual file transfers. -- ---------------------------------------------------------------------- PROCEDURE New_line; PROCEDURE Get_command_from_keyboard ( Keyboard_data : OUT Command_types.command_string_spec ); -- -- This procedure is responsible for getting data from the -- user's keyboard. -- PROCEDURE Output_message ( Error_message : IN CHARACTER ); PROCEDURE Output_message ( Error_message : IN STRING ); PROCEDURE Output_message_with_new_line ( Error_message : IN CHARACTER ); PROCEDURE Output_message_with_new_line ( Error_message : IN STRING ); END Ftp_terminal_driver; --:::::::::::::: --ftpterm.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01108-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTERM.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftpterm AUTHOR : MARK VOLPE -- 5/14/85 9:20 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/24/85 9:00 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/24/85 1:01 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY Ftp_terminal_driver IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE Int_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PACKAGE Long_Int_IO IS NEW TEXT_IO.INTEGER_IO(bit_count_32_type); PROCEDURE Get_command_from_keyboard ( Keyboard_data : OUT Command_types.command_string_spec ) IS Keyboard_data_length : BIT_COUNT_32_TYPE := 0; --&MT Keyboard_data_length : BIT_COUNT_16_TYPE := 0; BEGIN Keyboard_data := Command_types.null_command_string; TEXT_IO.PUT ("FTP> "); TEXT_IO.GET_LINE ( Keyboard_data, Keyboard_data_length ); Keyboard_data( Keyboard_data_length + 1 ) := ' '; -- -- Make last char a ' ' or get next word will bomb! -- Keyboard_data( Keyboard_data_length + 1) := ' '; EXCEPTION WHEN OTHERS => RAISE; END Get_command_from_keyboard; PROCEDURE NEW_LINE IS BEGIN TEXT_IO.NEW_LINE; END New_line; PROCEDURE Output_message ( Error_message : IN CHARACTER ) IS BEGIN TEXT_IO.PUT ( Error_message ); END Output_message; PROCEDURE Output_message( Error_message : IN STRING ) IS BEGIN FOR Index IN Error_message'RANGE LOOP IF Error_message( Index ) = ASCII.NUL THEN EXIT; ELSE Output_message( CHARACTER'( Error_message( Index ))); END IF; END LOOP; EXCEPTION WHEN OTHERS => RAISE; END Output_message ; PROCEDURE Output_message_with_new_line( Error_message : IN CHARACTER ) IS BEGIN Output_message ( Error_message ); New_line; EXCEPTION WHEN OTHERS => RAISE; END Output_message_with_new_line; PROCEDURE Output_message_with_new_line( Error_message : IN STRING ) IS BEGIN Output_message ( Error_message ); New_line; EXCEPTION WHEN OTHERS => RAISE; END Output_message_with_new_line; BEGIN NULL; EXCEPTION WHEN OTHERS =>RAISE; END Ftp_terminal_driver; --:::::::::::::: --ftptcp_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01103-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTCP_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPTCP AUTHOR : MARK VOLPE -- : Mike Thomas (post 7-4-84 modifications) -- 5/28/85 2:49 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/5/85 1:50 PM : modifications for new tcp interface -- 7/10/85 4:53 PM : make tcp_identifier_spec public -- 7/21/85 5:23 PM : buffer_size to 0 ; time_out to 15 --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH SYSTEM ; WITH with_ulp_communicate ; USE SYSTEM ; PACKAGE FTP_TCP IS ------- ---------------------------------------------------------------------- -- -- This package contains the procedures used by ftp to interface to tcp. -- These procedures may be implementation dependent depending on which -- tcp program is being used. -- ---------------------------------------------------------------------- --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.BYTE; SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.UNSIGNED_BYTE; TYPE Tcp_connection_status_spec IS ( Open, Closed ) ; TYPE Tcp_identifier_spec IS RECORD Connection_id : with_ulp_communicate.lcn_ptr_type ; Connection_status : Tcp_connection_status_spec := CLOSED ; Local_port_id : BIT_COUNT_16_TYPE ; END RECORD ; No_more_tcp_data : EXCEPTION ; Tcp_aborted : EXCEPTION ; Tcp_buffer_access_error : EXCEPTION ; Tcp_connection_closed : EXCEPTION ; Tcp_request_failed : EXCEPTION ; Unexpected_reply : EXCEPTION ; FUNCTION Tcp_connection_is_open ---------------------- (Tcp_identifier : IN Tcp_identifier_spec ) RETURN BOOLEAN ; ---------------------------------------------------------------------- -- -- This function is used to determine if a TCP connection is already open -- -- Exceptions: Tcp_request_failed. ---------------------------------------------------------------------- PROCEDURE Initialize_tcp (Tcp_identifier : IN OUT Tcp_identifier_spec) ; -------------- PROCEDURE Wait_for_tcp_connection_to_close -------------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec) ; PROCEDURE Open_tcp_data_link ------------------ (Tcp_identifier : IN OUT Tcp_identifier_spec ; buffer_size : IN BIT_COUNT_16_TYPE := 0 ; timeout : IN BIT_COUNT_16_TYPE := 15 ; security : IN BIT_COUNT_16_TYPE := 0 ; precedence : IN BIT_COUNT_16_TYPE := 0); ---------------------------------------------------------------------- -- -- This procedure is used to open a tcp connection. If a connection -- is already open then a new one is not opened. -- -- Exceptions: Tcp_request_failed. ---------------------------------------------------------------------- PROCEDURE Close_tcp_data_link (Tcp_identifier : IN OUT Tcp_identifier_spec) ; ------------------- ---------------------------------------------------------------------- -- -- This procedure is used to close a TCP connection. If a connection -- does not exist then nothing is done. -- -- Exceptions: Tcp_request_failed. ---------------------------------------------------------------------- PROCEDURE Load_byte_into_tcp_buffer ------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : IN CHARACTER ) ; ---------------------------------------------------------------------- -- -- This procedure loads a byte into the next avaliable buffer location. -- If the buffer is full, the current buffer is transmitted -- and the byte is then added at the start of a new buffer. -- -- Exceptions: Tcp_buffer_access_error. ---------------------------------------------------------------------- PROCEDURE Load_byte_into_tcp_buffer ------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : IN BIT_COUNT_8_TYPE ) ; ---------------------------------------------------------------------- -- -- This procedure loads a byte into the next avaliable buffer location. -- If the buffer is full, the current buffer is transmitted -- and the byte is then added at the start of a new buffer. -- -- Exceptions: Tcp_buffer_access_error. ---------------------------------------------------------------------- PROCEDURE Get_byte_from_tcp_buffer ------------------------ (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : OUT CHARACTER) ; ---------------------------------------------------------------------- -- -- This procedure is used to get the next byte from a tcp buffer. -- If there are no more bytes in the buffer then another buffer is -- retreived. -- -- Exceptions: Tcp_buffer_access_error. ---------------------------------------------------------------------- PROCEDURE Get_byte_from_tcp_buffer ------------------------ (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : OUT BIT_COUNT_8_TYPE ) ; ---------------------------------------------------------------------- -- -- This procedure is used to get the next byte from a tcp buffer. -- If there are no more bytes in the buffer then another buffer is -- retreived. -- -- Exceptions: Tcp_buffer_access_error. ---------------------------------------------------------------------- PROCEDURE Listen_on_current_tcp_port_for_an_active_open --------------------------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec) ; ---------------------------------------------------------------------- -- -- This procedure waits for the passive port to be opened actively. -- -- Exceptions: Tcp_request_failed. ---------------------------------------------------------------------- PROCEDURE Indicate_that_all_of_tcp_data_has_been_used ; ------------------------------------------- ---------------------------------------------------------------------- -- -- This procedure tells tcp that the current buffer is no longer -- required and may be freed up. -- ---------------------------------------------------------------------- PROCEDURE Push_tcp_buffer (Tcp_identifier : IN OUT Tcp_identifier_spec) ; --------------- ---------------------------------------------------------------------- -- -- This procedure pushes ( transmitts ) the current tcp buffer -- -- Exceptions: ---------------------------------------------------------------------- PROCEDURE Abort_tcp (Tcp_identifier : IN OUT Tcp_identifier_spec) ; --------- ---------------------------------------------------------------------- -- -- This procedure aborts tcp. -- -- Exceptions: None ---------------------------------------------------------------------- END FTP_TCP ; --:::::::::::::: --ftptcp.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01104-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTCP.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPTCP AUTHOR : MARK VOLPE -- : Mike Thomas (post 7/4/85 mods) -- 5/28/85 3:02 PM : revised for use with the dec compiler -- old code (telesoft) marked with --&MT -- 7/5/85 4:46 PM : mods for new tcp interface -- 7/11/85 11:33 AM : have init_tcp not do passive open for user (port #=-1) -- : so.. don't do abort before an open -- 6:06 PM : allow for 0's after open request -- 7/12/85 10:00 AM : save lcn after open requests -- 7/18/85 11:54 AM : fix problen saving lcn after getting #14 on pass open -- 7/19/85 11:05 AM : have listen for active open do a passive open first -- : hard wire assign port parameters procedure -- : don't do passive open during initialize_tcp -- 6:20 PM : fix for active open parameters -- 7/21/85 4:57 PM : buffer_size to 0, time_out to 15, set lcn before -- : wait_for_tcp_message -- 6:12 : change loop location in listen_for active open -- 7/22/85 11:38 AM : save lcn_ptr after #14 not #23 -- 3:41 PM : put debug in for monitoring actual transfer -- 7/23/85 9:53 AM : remove some debug -- 7:03 PM : size of ftp buffer made a constant -- 7/24/85 2:20 AM : comment out debug code -- 7/29/85 11:36 AM : put in ten sec delay on open to give other side time to passive WITH TEXT_IO ; WITH My_debug_io ; WITH UNCHECKED_CONVERSION ; WITH Buffer_data ; USE buffer_data ; -- need for access to equality operator on one of its data types WITH My_debug_io ; WITH My_utilities ; WITH vt100 ; PACKAGE BODY FTP_TCP IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER ; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER ; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE) ; PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE) ; PACKAGE SYSTEM_BYTE IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_8_TYPE) ; SUBTYPE Transfer_byte IS BIT_COUNT_8_TYPE ; Dummy_character : CHARACTER ; End_of_ftp_buffer : CONSTANT BIT_COUNT_16_TYPE := buffer_data.Telnet_size ; size_of_ftp_buffer : CONSTANT bit_count_16_type := 128 ; Max_tcp_timeout : CONSTANT BIT_COUNT_16_TYPE := 255 ; Precedence_value : CONSTANT BIT_COUNT_16_TYPE := 0 ; Security_value : CONSTANT BIT_COUNT_16_TYPE := 0 ; Start_of_ftp_buffer : CONSTANT BIT_COUNT_16_TYPE := 1 ; Bytes_loaded_into_buffer : BIT_COUNT_16_TYPE := 0 ; Bytes_removed_from_tcp_buffer : BIT_COUNT_16_TYPE := 0 ; Ftp_buffer_offset : BIT_COUNT_16_TYPE := Start_of_ftp_buffer - 1 ; Ftp_buffer_pointer : buffer_data.Tcp_ptr_type ; Push_flag_value : BIT_COUNT_16_TYPE := 0 ; Tcp_buffer_count : BIT_COUNT_16_TYPE := 0 ; Tcp_buffer_pointer : buffer_data.packed_buffer_ptr := NULL ; Timeout_value : BIT_COUNT_16_TYPE := Max_tcp_timeout ; Type_of_buffer : BIT_COUNT_16_TYPE := 0 ; Urgent_flag_value : BIT_COUNT_16_TYPE := 0 ; -- -- Ftp_buffer_pointer points to start of ftp data which is located in -- packed_buffer.byte which is pointed to by Tcp_buffer_pointer. -- Access a byte as: -- Tcp_buffer_pointer.Byte( Ftp_buffer_pointer + Ftp_buffer_offset) -- FUNCTION Character_to_byte IS ----------------- NEW UNCHECKED_CONVERSION(CHARACTER, BIT_COUNT_16_TYPE) ; FUNCTION Convert_integer_to_character IS ---------------------------- NEW UNCHECKED_CONVERSION(BIT_COUNT_16_TYPE, CHARACTER) ; FUNCTION Byte_to_character (In_byte : IN BIT_COUNT_16_TYPE) RETURN CHARACTER IS ----------------- Byte_string : STRING(1..2) ; BEGIN Byte_string(1) := Convert_integer_to_character (In_byte) ; RETURN Byte_string(1) ; END Byte_to_character ; --&MT PROCEDURE Cycle IS ----------------- may use in TeleSoft T B D --&MT ----- --&MT BEGIN -- cycle other protocals here too?? T B D --&MT --&MT -- My_debug_io.PUT_LINE (" Cycling ") ; --&MT --&MT FOR Index IN 1..1 LOOP --&MT --&MT Tcp_controller ; --&MT --&MT Ip_controller ; --&MT --&MT END LOOP ; --&MT NULL ; --&MT END CYCLE ; PROCEDURE Indicate_that_all_of_tcp_data_has_been_used IS ------------------------------------------- BEGIN Ftp_buffer_offset := Tcp_buffer_count ; END Indicate_that_all_of_tcp_data_has_been_used ; PROCEDURE Initialize_tcp_receive_queue (Tcp_identifier:Tcp_identifier_spec) IS ---------------------------- BUFFER : buffer_data.packed_buffer_ptr ; RECEIVE_DATA : with_ulp_communicate.RECEIVE_PARAMS ; TASK_MESSAGE : with_ulp_communicate.MESSAGE ; request_ok : BOOLEAN ; BEGIN buffer_data.Buffget(Buffer, 1) ; Receive_data := (tcp_identifier.connection_id, Buffer, 190) ; Task_message := (with_ulp_communicate.receive, Receive_data) ; --&MT Cycle ; with_ulp_communicate.message_for_tcp(Task_message, request_ok) ; --MT& Cycle ; END Initialize_tcp_receive_queue ; FUNCTION Tcp_connection_is_open ---------------------- (Tcp_identifier : IN Tcp_identifier_spec) RETURN BOOLEAN IS BEGIN RETURN Tcp_identifier.connection_status = Open ; EXCEPTION WHEN OTHERS => RAISE Tcp_request_failed ; END Tcp_connection_is_open ; PROCEDURE Output_tcp_response ------------------- (Tcp_response : IN With_ulp_communicate.user_message) IS BEGIN My_debug_io.PUT(" Tcp response was ") ; My_debug_io.PUT_LINE (Tcp_response.message_number) ; END Output_tcp_response ; PROCEDURE Set_the_port_up_to_allow_for_another_transfer --------------------------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec) IS Open_parameters : with_ulp_communicate.OPEN_PARAMS ; Tcp_message : with_ulp_communicate.MESSAGE ; Tcp_option : with_ulp_communicate.TCP_OPTION_TYPE ; Tcp_response : WITH_ULP_COMMUNICATE.USER_MESSAGE ; request_ok : BOOLEAN ; BEGIN FOR i IN 1..50 LOOP tcp_option(i) := 0 ; END LOOP ; OPEN_PARAMETERS := (Tcp_identifier.local_port_id, 0, 0, with_ulp_communicate.passive, 0, 60, tcp_identifier.connection_id, 0, 0, tcp_option) ; tcp_message := (with_ulp_communicate.open, open_parameters) ; with_ulp_communicate.message_for_tcp(tcp_message, request_ok) ; tcp_response.local_connection_name := tcp_message.open_parameters.local_connection_name ; tcp_identifier.connection_id := tcp_message.open_parameters.local_connection_name ; LOOP my_debug_io.put_line("set the port up") ; --&MT Cycle ; with_ulp_communicate.Wait_for_tcp_message (Tcp_response) ; --&MT Cycle ; Output_tcp_response(Tcp_response) ; CASE Tcp_response.message_number IS WHEN -1 | 0 => NULL ; WHEN 14 => tcp_identifier.connection_id.lcn_ptr := tcp_response.local_connection_name.lcn_ptr ; tcp_identifier.connection_status := closed ; -- this ok? EXIT ; WHEN OTHERS => RAISE Tcp_request_failed ; END CASE ; END LOOP ; END Set_the_port_up_to_allow_for_another_transfer ; PROCEDURE Wait_for_tcp_connection_to_close -------------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec) IS Tcp_response : With_ulp_communicate.user_message ; BEGIN tcp_response.local_connection_name := tcp_identifier.connection_id ; LOOP --&MT Cycle ; with_ulp_communicate.Wait_for_tcp_message (Tcp_response) ; --&MT Cycle ; Output_tcp_response(Tcp_response) ; CASE Tcp_response.message_number IS WHEN -1 | 0 => NULL ; WHEN 6 => Close_tcp_data_link(Tcp_identifier) ; EXIT ; WHEN 18 => EXIT ; WHEN OTHERS => RAISE Tcp_request_failed ; END CASE ; END LOOP ; END Wait_for_tcp_connection_to_close ; PROCEDURE Initialize_tcp (Tcp_identifier : IN OUT Tcp_identifier_spec) IS -------------- -- Tcp_response : WITH_ULP_COMMUNICATE.USER_MESSAGE ; -- can omit tcp_identifier parameter and above line BEGIN buffer_data.init ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE(" Unknown exception in Initialize tcp ") ; vt100.Attributes_off ; END Initialize_tcp ; PROCEDURE Open_tcp_data_link -- Does an active open ------------------ (Tcp_identifier : IN OUT Tcp_identifier_spec ; buffer_size : IN BIT_COUNT_16_TYPE := 0 ; timeout : IN BIT_COUNT_16_TYPE := 15 ; security : IN BIT_COUNT_16_TYPE := 0 ; precedence : IN BIT_COUNT_16_TYPE := 0) IS -- These parameters are used to do a tcp open -- They must all be assigned values before the open request Open_parameters : with_ulp_communicate.OPEN_PARAMS ; Foreign_port_id : BIT_COUNT_16_TYPE ; -- ID OF PORT TO OPEN Trash_foreign_net_host : BIT_COUNT_16_TYPE ; -- ID FOR FOREIGN HOST Foreign_net_host : BIT_COUNT_32_TYPE ; -- ID FOR FOREIGN HOST Options : with_ulp_communicate.TCP_OPTION_TYPE ; -- set to 0 Tcp_response : WITH_ULP_COMMUNICATE.USER_MESSAGE ; tcp_request : with_ulp_communicate.message ; abort_parameters : with_ulp_communicate.abort_close_params ; request_ok : BOOLEAN ; PROCEDURE Assign_open_parameters IS ---------------------- BEGIN --&MT THIS IS FOR DEMO, IN FUTURE... -- HAVE SERVER ALWAYS DO PASSIVE OPENS AND USER ALWAYS DO ACTIVE OPENS foreign_net_host := 1 ; IF tcp_identifier.local_port_id = 5 THEN -- user ftp foreign_port_id := 6 ; ELSIF tcp_identifier.local_port_id = 6 THEN -- server ftp foreign_port_id := 5 ; END IF ; FOR i IN 1..50 LOOP options(i) := 0 ; END LOOP ; open_parameters := (tcp_identifier.local_port_id, foreign_port_id, foreign_net_host, with_ulp_communicate.active, buffer_size, timeout, tcp_identifier.connection_id, security, precedence, options) ; END Assign_open_parameters ; PROCEDURE Get_tcp_response_to_open_request IS -------------------------------- BEGIN LOOP --&MT Cycle ; tcp_response.local_connection_name := tcp_identifier.connection_id ; with_ulp_communicate.Wait_for_tcp_message (Tcp_response) ; --&MT Cycle ; Output_tcp_response(Tcp_response) ; CASE Tcp_response.message_number IS WHEN -1 | 0 => -- noop NULL ; WHEN 12 => -- connection already exists Tcp_identifier.connection_status := Open ; EXIT ; WHEN 14 => -- return lcn from tcp tcp_identifier.connection_id.lcn_ptr := tcp_response.local_connection_name.lcn_ptr ; WHEN 8 | 16 => -- abort request response (when passive open aborted) NULL ; WHEN 23 => -- OPEN My_debug_io.PUT_LINE (" Connection Opened") ; Tcp_identifier.connection_status := Open ; EXIT ; WHEN OTHERS => My_debug_io.PUT_LINE (" Open request failed ") ; Tcp_identifier.connection_status := Closed ; RAISE Tcp_request_failed ; END CASE ; END LOOP ; END Get_tcp_response_to_open_request ; BEGIN -- open_tcp_data_link --MT size_of_ftp_buffer := buffer_size ; Assign_open_parameters ; -- -- abort passive open -- abort_parameters := (local_connection_name => -- tcp_identifier.connection_id) ; -- tcp_request := (with_ulp_communicate.abor_t, abort_parameters) ; -- --&MT cycle -- with_ulp_communicate.message_for_tcp(tcp_request, request_ok) ; -- --&MT cycle -- request active open DELAY(DURATION(10)) ; -- allow other side to do passive open tcp_request := (with_ulp_communicate.open, open_parameters) ; --&MT cycle with_ulp_communicate.message_for_tcp(tcp_request, request_ok) ; --&MT cycle tcp_identifier.connection_id := tcp_request.open_parameters.local_connection_name ; Get_tcp_response_to_open_request ; Initialize_tcp_receive_queue(Tcp_identifier) ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" OPEN_TCP_DATA_LINK FAILED ") ; Tcp_identifier.connection_status := Closed ; RAISE Tcp_request_failed ; END OPEN_TCP_DATA_LINK ; PROCEDURE Close_tcp_data_link (Tcp_identifier : IN OUT Tcp_identifier_spec) IS ------------------- -- The node that performs the close request will receive an 18 -- reply. -- The node that receives the close request will receive a 6 -- reply and must then send a close request which results in an 18. Tcp_request : with_ulp_communicate.MESSAGE ; Close_parameters : with_ulp_communicate.abort_close_params ; Tcp_response : WITH_ULP_COMMUNICATE.USER_MESSAGE ; request_ok : BOOLEAN ; BEGIN IF Tcp_connection_is_open (Tcp_identifier) THEN My_debug_io.PUT_LINE(" Closing tcp link ") ; close_parameters.local_connection_name := tcp_identifier.connection_id ; tcp_request := (with_ulp_communicate.close, close_parameters) ; --&MT cycle ; DELAY(DURATION(10)) ; -- allow last data packet to be delivered with_ulp_communicate.message_for_tcp(tcp_request, request_ok) ; --&MT cycle ; LOOP --&MT cycle ; tcp_response.local_connection_name := tcp_identifier.connection_id ; with_ulp_communicate.Wait_for_tcp_message(tcp_response) ; --&MT cycle ; output_tcp_response(tcp_response) ; CASE tcp_response.message_number IS WHEN -1 => -- noop NULL ; WHEN 3 => -- connection does not exist my_debug_io.put_line("connection does not exist") ; tcp_identifier.connection_status := closed ; RAISE tcp_connection_closed ; WHEN 6 => -- SHOULD NEVER GET THIS NULL ; WHEN 8 | 16 => -- connection abort/reset my_debug_io.put_line("connection abort/reset") ; tcp_identifier.connection_status := closed ; EXIT ; WHEN 18 => -- closed my_debug_io.put_line("connection closed") ; tcp_identifier.connection_status := closed ; EXIT ; WHEN OTHERS => my_debug_io.put_line("TCP CLOSE REQUEST FAILED") ; RAISE tcp_request_failed ; END CASE ; END LOOP ; Set_the_port_up_to_allow_for_another_transfer(Tcp_identifier) ; ELSE My_debug_io.PUT_LINE (" Tcp connection not open ") ; END IF ; EXCEPTION WHEN TCP_REQUEST_FAILED => MY_DEBUG_IO.PUT_LINE (" Tcp request failed ") ; RAISE ; WHEN TCP_CONNECTION_CLOSED => MY_DEBUG_IO.PUT_LINE (" tcp connection closed ") ; RAISE ; WHEN OTHERS => My_debug_io.PUT_LINE (" Unknown exception in Close_tcp_data_link") ; RAISE Tcp_request_failed ; END Close_tcp_data_link ; PROCEDURE Load_byte_into_tcp_buffer ------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : IN BIT_COUNT_8_TYPE) IS PROCEDURE Get_a_tcp_buffer IS ---------------- BEGIN --dmt my_debug_io.put_line("get a tcp_buffer") ; buffer_data.Buffget (Tcp_buffer_pointer, Type_of_buffer) ; Ftp_buffer_pointer := Tcp_buffer_pointer.telnet_ptr ; Ftp_buffer_offset := 0 ; -- No offset from ftp_buffer_pointer Bytes_loaded_into_buffer := 0 ; END Get_a_tcp_buffer ; BEGIN -- load_byte_into_tcp_buffer --dmt my_debug_io.put_line("load_byte_into_tcp_buffer") ; IF Tcp_buffer_pointer = NULL THEN Get_a_tcp_buffer ; ELSIF Bytes_loaded_into_buffer >= size_of_ftp_buffer THEN Push_tcp_buffer (Tcp_identifier) ; Get_a_tcp_buffer ; END IF ; -- -- Data is loaded inwards ; first byte comes in at telnet_ptr, -- the next byte is at telnet_ptr - 1. -- Tcp_buffer_pointer.byte (Ftp_buffer_pointer - Ftp_buffer_offset) := Tcp_data ; Bytes_loaded_into_buffer := Bytes_loaded_into_buffer + 1 ; --My_debug_io.PUT (" Bytes_loaded_into_buffer = ") ; --My_debug_io.put_line (Bytes_loaded_into_buffer) ; --My_debug_io.PUT (" Ftp_buffer_pointer = ") ; --My_debug_io.put_line (Ftp_buffer_pointer) ; --My_debug_io.PUT (" Ftp_buffer_offset = ") ; --My_debug_io.put_line (Ftp_buffer_offset) ; --my_debug_io.put("tcp_data is >") ; --IF tcp_data in 0..127 THEN -- My_utilities.output_byte_to_screen (Tcp_data) ; -- my_debug_io.put_line(" ") ; --ELSE -- my_debug_io.put_line("uprintable") ; --END IF ; Ftp_buffer_offset := Ftp_buffer_offset + 1 ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE(" Load_byte_into_tcp_buffer FAILED ") ; RAISE Tcp_buffer_access_error ; END Load_byte_into_tcp_buffer ; PROCEDURE Load_byte_into_tcp_buffer ------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : IN CHARACTER) IS BEGIN Load_byte_into_tcp_buffer (Tcp_identifier,bit_count_8_type(Character_to_byte(Tcp_data))) ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE(" Load_byte_into_tcp_buffer failed ") ; My_debug_io.PUT_LINE(" Raising Tcp_buffer_access_error ") ; RAISE Tcp_buffer_access_error ; END Load_byte_into_tcp_buffer ; PROCEDURE Get_byte_from_tcp_buffer ------------------------ (Tcp_identifier : IN OUT Tcp_identifier_spec ; Tcp_data : OUT BIT_COUNT_8_TYPE) IS TEMP_TCP_DATA : BIT_COUNT_8_TYPE ; --&MT FOR DEBUG Receive_parameters : with_ulp_communicate.RECEIVE_PARAMS ; Tcp_request : with_ulp_communicate.MESSAGE := (with_ulp_communicate.receive, receive_parameters) ; Tcp_response : with_ulp_communicate.User_message ; PROCEDURE Get_a_data_buffer_from_tcp IS -------------------------- PROCEDURE Dump_the_received_buffer_to_the_screen IS -------------------------------------- Temp_byte : BIT_COUNT_8_TYPE ; BEGIN -- Dump_the_received_buffer_to_the_screen My_debug_io.put_Line (" Output the buffer to the screen ") ; FOR Offset IN 0..(Tcp_buffer_count - 1) LOOP My_debug_io.put (" Character location = ") ; My_debug_io.put_line (Ftp_buffer_pointer - Offset) ; My_debug_io.put_line (" Assigning byte ") ; Temp_byte := Tcp_buffer_pointer.byte(Ftp_buffer_pointer - Offset) ; My_debug_io.put (" Byte = ") ; IF temp_byte in 0..127 THEN My_utilities.output_byte_to_screen (TEMP_BYTE) ; my_debug_io.put_line(" ") ; ELSE my_debug_io.put_line("uprintable") ; END IF ; TEXT_IO.NEW_LINE ; END LOOP ; My_debug_io.put_Line (" Buffer has been output to the screen ") ; END Dump_the_received_buffer_to_the_screen ; PROCEDURE prepare_buffer_for_processing IS ----------------------------- BEGIN tcp_buffer_pointer := tcp_response.data_buffer ; tcp_buffer_count := tcp_buffer_pointer.telnet_ptr - tcp_buffer_pointer.tcp_ptr ; ftp_buffer_offset := 0 ; ftp_buffer_pointer := tcp_buffer_pointer.telnet_ptr ; initialize_tcp_receive_queue(tcp_identifier) ; bytes_removed_from_tcp_buffer := 0 ; END prepare_buffer_for_processing ; BEGIN -- Get_a_data_buffer_from_tcp LOOP --dmt my_debug_io.put_line("Get_a_data_buffer_from_tcp ") ; tcp_response.local_connection_name := tcp_identifier.connection_id ; --&MT Cycle ; with_ulp_communicate.Wait_for_tcp_message (Tcp_response) ; -- Get response --&MT Cycle ; Output_tcp_response(Tcp_response) ; CASE Tcp_response.message_number IS -- Test response WHEN -1 => -- no user action NULL ; WHEN 3 => -- Connection does not exist Tcp_identifier.connection_status := Closed ; RAISE Tcp_connection_closed ; WHEN 6 => -- Connection closing Close_tcp_data_link(Tcp_identifier) ; WHEN 10 | 19 => -- Buffer avaliable Prepare_buffer_for_processing ; --D dump_the_received_buffer_to_the_screen ; --&MT debug EXIT ; WHEN 24 | 8 | 16 => -- time out, abort, aborted on Tcp_identifier.connection_status := Closed ; RAISE Tcp_connection_closed ; WHEN OTHERS => RAISE Tcp_request_failed ; END CASE ; END LOOP ; EXCEPTION WHEN Tcp_connection_closed => My_debug_io.PUT_LINE(" Get_a_tcp_data_buffer failed ") ; My_debug_io.PUT_LINE(" Raising Tcp_connection_closed ") ; RAISE Tcp_connection_closed ; WHEN OTHERS => My_debug_io.PUT_LINE(" Get_a_tcp_data_buffer failed ") ; My_debug_io.PUT_LINE(" Raising tcp_request_failed ") ; RAISE Tcp_request_failed ; END Get_a_data_buffer_from_tcp ; BEGIN -- get_byte_from_tcp_buffer IF Tcp_buffer_pointer = NULL THEN get_a_data_buffer_from_tcp ; ELSIF Bytes_removed_from_tcp_buffer >= Tcp_buffer_count THEN buffer_data.Buffree (Tcp_buffer_pointer, Type_of_buffer) ; get_a_data_buffer_from_tcp ; END IF ; Tcp_data := Tcp_buffer_pointer.byte (Ftp_buffer_pointer - Ftp_buffer_offset) ; --&MT debug --dmt TEMP_Tcp_data := Tcp_buffer_pointer.byte --dmt (Ftp_buffer_pointer - Ftp_buffer_offset) ; --dmt --dmt IF TEMP_tcp_data IN 32..126 THEN --dmt my_debug_io.put("get_byte_from_tcp_buffer.tcp_data=") ; --dmt TEXT_io.put(CHARACTER'VAL(integer(TEMP_tcp_data))) ; --dmt TEXT_IO.NEW_LINE ; --dmt ELSE --dmt my_debug_io.put("get_byte_from_tcp_buffer.tcp_data NUMBER =") ; --dmt my_debug_io.put_line(bit_count_16_type(TEMP_tcp_data)) ; --dmt END IF ; --&MT DEBUG Ftp_buffer_offset := Ftp_buffer_offset + 1 ; Bytes_removed_from_tcp_buffer := Bytes_removed_from_tcp_buffer + 1 ; EXCEPTION WHEN Tcp_connection_closed => My_debug_io.PUT_LINE(" Get_byte_from_tcp_buffer failed ") ; My_debug_io.PUT_LINE(" Raising No_more_tcp_data ") ; RAISE No_more_tcp_data ; WHEN Tcp_request_failed => My_debug_io.PUT_LINE(" Get_byte_from_tcp_buffer failed ") ; My_debug_io.PUT_LINE(" Raising Tcp_request_failed ") ; RAISE Tcp_request_failed ; WHEN OTHERS => My_debug_io.PUT_LINE(" Get_byte_from_tcp_buffer failed ") ; My_debug_io.PUT_LINE(" Raising Tcp_buffer_access_error ") ; RAISE Tcp_buffer_access_error ; END Get_byte_from_tcp_buffer ; PROCEDURE Get_byte_from_tcp_buffer ------------------------ (TCP_IDENTIFIER : IN OUT TCP_IDENTIFIER_SPEC ; TCP_DATA : OUT CHARACTER) IS Temp_tcp_data : BIT_COUNT_8_TYPE ; BEGIN Get_byte_from_tcp_buffer (Tcp_identifier, Temp_tcp_data) ; Tcp_data := Byte_to_character (bit_count_16_type(Temp_tcp_data)) ; EXCEPTION WHEN Tcp_connection_closed => My_debug_io.PUT_LINE(" Get_byte_from_tcp_buffer ;failed ") ; My_debug_io.PUT_LINE(" Raising No_more_tcp_data ; ") ; RAISE No_more_tcp_data ; WHEN Tcp_request_failed => My_debug_io.PUT_LINE(" Get_byte_from_tcp_buffer ;failed ") ; My_debug_io.PUT_LINE(" Raising Tcp_request_failed ; ") ; RAISE Tcp_request_failed ; WHEN OTHERS => My_debug_io.PUT_LINE(" Get_byte_from_tcp_buffer ;failed ") ; My_debug_io.PUT_LINE(" Raising Tcp_buffer_access_error ; ") ; RAISE Tcp_buffer_access_error ; END Get_byte_from_tcp_buffer ; PROCEDURE Listen_on_current_tcp_port_for_an_active_open --------------------------------------------- (Tcp_identifier : IN OUT Tcp_identifier_spec) IS Tcp_response : WITH_ULP_COMMUNICATE.USER_MESSAGE ; BEGIN My_debug_io.PUT_LINE (" Waiting for an active open ") ; set_the_port_up_to_allow_for_another_transfer(tcp_identifier) ; --&MT Cycle ; tcp_response.local_connection_name := tcp_identifier.connection_id ; LOOP my_debug_io.put_line("listen for active") ; with_ulp_communicate.Wait_for_tcp_message (Tcp_response) ; -- Get response --&MT Cycle ; Output_tcp_response(Tcp_response) ; CASE Tcp_response.message_number IS -- Test response WHEN -1 | 0 => -- no user action ; keep on waiting NULL ; WHEN 23 => -- Connection exists My_debug_io.PUT_LINE (" Active open received ") ; Tcp_identifier.connection_status := open ; Initialize_tcp_receive_queue (Tcp_identifier) ; EXIT ; -- Get out of loop! WHEN OTHERS => RAISE Tcp_request_failed ; END CASE ; END LOOP ; END Listen_on_current_tcp_port_for_an_active_open ; PROCEDURE Push_tcp_buffer --------------- (Tcp_identifier : IN OUT Tcp_identifier_spec) IS Send_parameters : with_ulp_communicate.Send_params ; Tcp_request : with_ulp_communicate.MESSAGE ; Tcp_response : with_ulp_communicate.User_message ; request_ok : BOOLEAN ; PROCEDURE Dump_the_buffer_to_be_pushed_to_the_screen IS ------------------------------------------ Temp_byte : BIT_COUNT_8_TYPE ; BEGIN My_debug_io.put_Line (" Output the push buffer to the screen ") ; FOR Offset IN 0 .. (Tcp_buffer_count - 1) LOOP My_debug_io.put (" Character location = ") ; My_debug_io.put_line (Ftp_buffer_pointer - Offset) ; My_debug_io.put_line (" Assigning byte ") ; Temp_byte := Tcp_buffer_pointer.byte(Ftp_buffer_pointer - Offset) ; My_debug_io.put (" Next byte is ") ; IF temp_byte in 0..127 THEN MY_UTILITIES.OUTPUT_BYTE_TO_SCREEN(Temp_byte ) ; TEXT_IO.NEW_LINE ; ELSE my_debug_io.put_line("unprintable") ; END IF ; END LOOP ; My_debug_io.put_Line (" Buffer has been output to the screen ") ; END Dump_the_buffer_to_be_pushed_to_the_screen ; BEGIN -- push_tcp_buffer --dmt my_debug_io.put_line("pushing tcp buffer") ; Tcp_buffer_count := Bytes_loaded_into_buffer ; Tcp_buffer_pointer.Telnet_ptr := Tcp_buffer_pointer.Telnet_ptr - Tcp_buffer_count ; Tcp_buffer_pointer.Tcp_ptr := Tcp_buffer_pointer.Telnet_ptr - 1 ; --D my_debug_io.put("tcp_buffer_count=") ; -- my_debug_io.put_line(tcp_buffer_count) ; -- my_debug_io.put_line("telnet_pionter=") ; -- my_debug_io.put_line(Tcp_buffer_pointer.Telnet_ptr ) ; -- my_debug_io.put_line("tcp_ptr=") ; -- my_debug_io.put_line(Tcp_buffer_pointer.Tcp_ptr ) ; --D Dump_the_buffer_to_be_pushed_to_the_screen ; --&MT debug Send_parameters := (Tcp_identifier.connection_id, Tcp_buffer_pointer, Tcp_buffer_count, Push_flag_value, Urgent_flag_value, Timeout_value) ; Tcp_request := (with_ulp_communicate.Send, Send_parameters) ; --&MT Cycle ; with_ulp_communicate.message_for_tcp (Tcp_request, request_ok) ; --&MT Cycle ; Tcp_buffer_pointer := NULL ; --&MT Give_tcp_time_to_deliver ; -- this looped 50,000 times EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" Push failed ") ; My_debug_io.put_line (" Raising tcp_request_failed ") ; RAISE Tcp_request_failed ; END Push_tcp_buffer ; PROCEDURE abort_tcp (tcp_identifier : IN OUT tcp_identifier_spec) IS -------- ----------------------------------------------------------------- -- -- This procedure is used to abort a tcp data transfer and close -- a tcp connection. ----------------------------------------------------------------- Abort_parameters : with_ulp_communicate.abort_close_params ; Tcp_request : with_ulp_communicate.MESSAGE := (with_ulp_communicate.Abor_t, Abort_parameters) ; Tcp_response : with_ulp_communicate.User_message ; request_ok : BOOLEAN ; PROCEDURE Get_tcp_response_to_abort_request IS BEGIN tcp_response.local_connection_name := tcp_identifier.connection_id ; LOOP --&MT cycle with_ulp_communicate.Wait_for_tcp_message (Tcp_response) ; --&MT cycle Output_tcp_response(Tcp_response) ; CASE Tcp_response.message_number IS WHEN -1 | 0 => NULL ; WHEN 8 => Tcp_identifier.connection_status := CLOSED ; RAISE Tcp_aborted ; WHEN OTHERS => RAISE Tcp_request_failed ; END CASE ; END LOOP ; END Get_tcp_response_to_abort_request ; BEGIN -- abort_tcp Abort_parameters.local_connection_name := Tcp_identifier.connection_id ; with_ulp_communicate.message_for_tcp (Tcp_request, request_ok) ; Get_tcp_response_to_abort_request ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" ABORT_TCP FAILED ") ; My_debug_io.PUT_LINE (" raising tcp_request_failed ") ; RAISE Tcp_request_failed ; END abort_tcp ; BEGIN -- ftp_tcp NULL ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" FTP_TCP FAILED ") ; RAISE Tcp_request_failed ; END FTP_TCP ; --:::::::::::::: --ftptelnet_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01105-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTELNET_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPTELNET AUTHOR : MARK VOLPE -- : Mike Thomas (post 7-8-85 mods) -- 5/15/85 3:10 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/29/85 12:36 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 8:16 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/9/85 5:38 PM : mods for new tcp interface and dec version --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ) ; WITH TEXT_IO ; WITH SYSTEM ; USE SYSTEM ; --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT WITH ASCII ; WITH Command_types ; WITH Ftp_types ; PACKAGE FTP_TELNET IS ---------------------------------------------------------------------- -- -- This package contains the necessary procedures to interface to -- a particular telnet implementation. All these procedures are -- implementation dependent. -- ---------------------------------------------------------------------- --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER ; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER ; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER ; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER ; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE) ; PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE) ; TYPE TELNET_STATUS_SPEC IS PRIVATE ; FUNCTION TELNET_FAILED ( STATUS : IN TELNET_STATUS_SPEC ) RETURN BOOLEAN ; FUNCTION TELNET_WAS_SUCCESSFUL ( STATUS : IN TELNET_STATUS_SPEC ) RETURN BOOLEAN ; PROCEDURE Wait_for_telnet_close( STATUS : OUT TELNET_STATUS_SPEC) ; PROCEDURE Wait_for_telnet_open( STATUS : OUT TELNET_STATUS_SPEC) ; PROCEDURE LOAD_TELNET_TRANSMISSION_BUFFER ( STATUS : OUT TELNET_STATUS_SPEC ; INPUT_LENGTH : IN BIT_COUNT_32_TYPE ; INPUT_STRING : IN COMMAND_TYPES.COMMAND_STRING_SPEC ; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) ; -- -- This procedure is responsible for giving data to telnet -- for transmission to either a server- or user- pi. -- PROCEDURE GET_DATA_FROM_TELNET_BUFFER ( STATUS : OUT TELNET_STATUS_SPEC ; TELNET_DATA : OUT COMMAND_TYPES.COMMAND_STRING_SPEC) ; -- -- This procedure is responsible for getting data from telnet -- for either a user- or server- pi. -- PROCEDURE OPEN_TELNET_LINK ( STATUS : OUT TELNET_STATUS_SPEC ; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) ; -- -- This procedure requests that a telnet connection be -- established between the user- and server- pi. -- PROCEDURE CLOSE_TELNET_LINK ( STATUS : OUT TELNET_STATUS_SPEC ; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) ; -- -- This procedure is used by the server system to close a -- telnet link. It is initiated at the request of the user -- system. -- PRIVATE TYPE TELNET_STATUS_SPEC IS ( TELNET_LINK_FAILED, TELNET_LINK_SUCCESSFUL ) ; END FTP_TELNET ; --:::::::::::::: --ftptelnet.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01106-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPTELNET.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPTELNET AUTHOR : MARK VOLPE -- : Mike Thomas (post 7/8/85 mods) -- 5/15/85 3:10 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/29/85 12:36 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 8:21 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/9/85 5:44 PM : mods for new tcp interface and dec -- 7/12/85 5:18 PM : add dec_tn_tasks.tn.go after sending to telnet -- 7/17/85 2:31 PM : make option responce test for either string -- 6:09 PM : don't look for more characters after "connection open" -- 7/18/85 11:57 AM : on active open too ; option responce has lfcr at end WITH dec_tn_tasks ; --&MT WITH user_data ; WITH telnet_package ; WITH virtual_terminal ; WITH my_debug_io ; WITH my_utilities ; PACKAGE BODY FTP_TELNET IS --&MT SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.BYTE; SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.UNSIGNED_BYTE; --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING TELESOFT PACKAGE SYSTEM_BYTE IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_8_TYPE); Next_telnet_character : BIT_COUNT_8_TYPE; Telnet_is_idle : BOOLEAN := FALSE; Telnet_index : BIT_COUNT_16_TYPE := 0; User_control_block : Telnet_package.User_info_type; --&MT PROCEDURE Cycle IS --- may need this for wicat --&MT BEGIN --&MT -- My_debug_io.PUT_LINE (" Cycling "); --&MT FOR Index IN 1..1 LOOP --&MT Tcp_controller; --&MT Ip_controller; --&MT END LOOP; --&MT null; --&MT END Cycle; --&MT --&MT PROCEDURE Cycle_telnet IS -- may need this for wicat --&MT BEGIN --&MT -- DEBUG_IO.PUT_LINE (" In cycle telnet"); --&MT Telnet_is_idle := FALSE; --&MT WHILE NOT Telnet_is_idle LOOP --&MT -- MY_DEBUG_IO.PUT_LINE (" Cycling telnet "); --&MT Telnet_package.telnet ( User_control_block, Telnet_is_idle ); --&MT -- Dump_all( User_control_block ); --&MT FOR Index_2 IN 1..4 LOOP --&MT -- MY_DEBUG_IO.PUT_LINE (" Cycling TCP "); --&MT Tcp_controller; --&MT Ip_controller; --&MT END LOOP; --&MT END LOOP; --&MT -- DEBUG_IO.PUT_LINE (" Exiting cycle telnet"); --&MT END Cycle_telnet; PROCEDURE Output_next_telnet_character IS ---------------------------- BEGIN MY_DEBUG_IO.PUT (" Next_telnet_character = "); TEXT_IO.PUT(my_utilities.Char(BIT_COUNT_16_TYPE(Next_telnet_character))); TEXT_IO.NEW_LINE; END Output_next_telnet_character; PROCEDURE Wait_for_telnet_to_receive_a_character IS -------------------------------------- BEGIN -- Text_io.new_line; LOOP -- My_debug_io.put_line (" Waiting to get a character"); IF virtual_terminal.There_are_characters_in_printer_buffer(1) THEN -- MY_DEBUG_IO.PUT_LINE (" Character received"); EXIT; ELSE --&MT Cycle_telnet; NULL ; --&MT END IF; END LOOP; END Wait_for_telnet_to_receive_a_character; PROCEDURE Process_echoed_data IS -------------------- BEGIN -- MY_DEBUG_IO.PUT_LINE (" Process local echo"); LOOP Wait_for_telnet_to_receive_a_character; virtual_terminal.Get_next_character_from_telnet(1, Next_telnet_character ); -- my_utilities.Output_byte_to_screen ( Next_telnet_character ); IF BIT_COUNT_16_TYPE(Next_telnet_character) = BIT_COUNT_16_TYPE(my_utilities.Byte( ASCII.CR )) THEN -- MY_DEBUG_IO.PUT_LINE (" <CR> after echoed data found"); EXIT; END IF; END LOOP; -- TEXT_IO.NEW_LINE; END Process_echoed_data; PROCEDURE Verify_suppress_telnet_go_ahead_request --------------------------------------- (Status : OUT Telnet_status_spec) IS --&MT str_length_1 : CONSTANT bit_count_16_type := 44 ; --&MT str_length_2 : CONSTANT bit_count_32_type := 45 ; str_length_1 : CONSTANT bit_count_32_type := 44 ; str_length_2 : CONSTANT bit_count_32_type := 45 ; eol : STRING(1..2) ; Verification_string_1 : STRING(1..str_length_1) ; Verification_string_2 : STRING(1..str_length_2) ; string_1_found : BOOLEAN := FALSE ; string_2_found : BOOLEAN := FALSE ; --&MT string_length : bit_count_16_type ; string_length : bit_count_32_type ; tn_input_string : STRING (1..80) ; char : CHARACTER ; BEGIN eol(1) := ASCII.LF ; eol(2) := ASCII.CR ; Verification_string_1 := "$@$ local suppress_ga option in effect $@$" & eol ; Verification_string_2 := "$@$ remote suppress_ga option in effect $@$" & eol ; FOR index in 1..2 LOOP char := ASCII.NUL ; string_length := 0 ; WHILE char /= ASCII.CR LOOP Wait_for_telnet_to_receive_a_character ; virtual_terminal.Get_next_character_from_telnet(1, next_telnet_character) ; string_length := string_length + 1 ; char := CHARACTER'VAL(INTEGER(next_telnet_character)) ; tn_input_string(string_length) := char ; END LOOP ; IF string_length = str_length_1 AND THEN tn_input_string(1..string_length) = verification_string_1(1..str_length_1) THEN string_1_found := TRUE ; ELSIF string_length = str_length_2 AND THEN tn_input_string(1..string_length) = verification_string_2(1..str_length_2) THEN string_2_found := TRUE ; END IF ; END LOOP ; --d IF string_1_found AND string_2_found THEN -- status := Telnet_link_successful ; -- my_debug_io.put_line("both strings found") ; -- ELSE -- status := Telnet_link_failed ; -- my_debug_io.put_line("both strings NOT found") ; --d END IF ; END Verify_suppress_telnet_go_ahead_request; PROCEDURE Wait_for_telnet_open ( STATUS : OUT TELNET_STATUS_SPEC ) IS -------------------- Open_verification : CONSTANT STRING (1..15) := "connection open"; Temp_Status : Telnet_Status_Spec; BEGIN -- My_debug_io.put_line (" Waiting for a telnet open"); Temp_Status := Telnet_link_successful; Telnet_package.telnet_request_to_do_option ( User_data.suppress_ga, User_control_block); Telnet_package.telnet_request_remote_to_do_option ( User_data.suppress_ga, User_control_block); FOR Index IN Open_verification'RANGE LOOP Wait_for_telnet_to_receive_a_character; virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( Open_verification( Index ))) THEN -- MY_DEBUG_IO.PUT (" Testing against "); -- my_utilities.Output_byte_to_screen ( Byte ( Open_verification( Index ))); -- TEXT_IO.NEW_LINE; MY_DEBUG_IO.PUT_LINE (" Bad verification of telnet open"); Temp_Status := Telnet_link_failed; EXIT; END IF; END LOOP; IF Temp_Status = Telnet_link_successful THEN Wait_for_telnet_to_receive_a_character; virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); -- Output_next_telnet_character ; IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( ASCII.CR )) THEN MY_DEBUG_IO.PUT_LINE (" Bad verification of telnet open"); Temp_Status := Telnet_link_failed; END IF; END IF; -- My_debug_io.put_line (" Finished waiting for telnet open"); IF Temp_Status = Telnet_link_successful THEN -- My_debug_io.put_line (" Open was ok"); Verify_suppress_telnet_go_ahead_request( Temp_Status ); ELSE NULL; -- My_debug_io.put_line (" Open was bad"); END IF; Status := Temp_Status; END Wait_for_telnet_open; PROCEDURE Wait_for_telnet_close( STATUS : OUT TELNET_STATUS_SPEC ) IS --------------------- Close_verification : CONSTANT STRING(1..17) := "connection closed"; Temp_Status : Telnet_Status_Spec; BEGIN -- My_debug_io.put_line (" Waiting for close"); FOR Index IN Close_verification'RANGE LOOP Wait_for_telnet_to_receive_a_character; virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); -- My_debug_io.put (" Good data is "); -- my_utilities.Output_byte_to_screen ( my_utilities.Byte( Close_verification( Index ))); -- My_debug_io.put (" Received data is "); -- my_utilities.Output_byte_to_screen ( Next_telnet_character ); -- TEXT_IO.NEW_LINE; IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( Close_verification( Index ))) THEN MY_DEBUG_IO.PUT_LINE (" Comparison failed"); Temp_Status := Telnet_link_failed; EXIT; END IF; END LOOP; IF virtual_terminal.There_are_characters_in_printer_buffer(1) THEN virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( ASCII.CR )) THEN Temp_Status := Telnet_link_failed; END IF; END IF; -- My_debug_io.put_line (" Checking for extra data"); IF virtual_terminal.There_are_characters_in_printer_buffer(1) THEN MY_DEBUG_IO.PUT_LINE (" Extra data found"); Temp_Status := Telnet_link_failed; END IF; -- IF Temp_Status = Telnet_link_successful THEN -- My_debug_io.put_line (" Close was ok"); -- ELSE -- My_debug_io.put_line (" Close was bad"); -- END IF; Status := Temp_Status; END Wait_for_telnet_close; PROCEDURE Open_telnet_link ---------------- ( Status : OUT Telnet_status_spec; Argument : IN Ftp_types.argument_list ) IS ----------------------------------------------------------------- -- -- RFC 765 Spec References: -- p. 6: The user pi initiates the telnet connection. -- p. 21:The connection is established by a tcp connection -- from the user to the standard server port. -- -- This procedure is responsible for opening a telnet connection -- to the server pi. -- ----------------------------------------------------------------- Open_verification : CONSTANT STRING (1..15) := "connection open"; Temp_Status : Telnet_Status_Spec; BEGIN -- telnet dependent -- My_debug_io.put_line (" Opening telnet connection"); Temp_Status := Telnet_link_successful; Telnet_package.telnet_request_to_do_option ( User_data.suppress_ga, User_control_block); Telnet_package.telnet_request_remote_to_do_option ( User_data.suppress_ga, User_control_block); -- Do the open -- My_debug_io.put_line (" Loading the open request"); -- My_debug_io.put( "@" ); virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( '@' ))); -- My_debug_io.put( "O" ); virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( 'o' ))); virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( ' ' ))); FOR Index IN Argument'RANGE LOOP -- My_debug_io.put (" Sending "); -- my_utilities.Output_byte_to_screen (my_utilities.Byte( Argument( Index ))); -- My_debug_io.put_line (" to telnet"); IF Argument( Index ) = Ftp_types.argument_list_unit'(ASCII.NUL) THEN -- My_debug_io.put_line( " End of command found " ); EXIT; ELSE -- My_debug_io.put( "-" ); virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( Argument( Index )))); -- My_debug_io.put( "-" ); END IF; END LOOP; -- My_debug_io.put_line (" Sending a <CR> to telnet"); virtual_terminal.Send_char_to_telnet (1, BIT_COUNT_8_TYPE(my_utilities.Byte(Ascii.cr))); dec_tn_tasks.tn.go ; -- tell telnet it has input to process -- MY_DEBUG_IO.PUT_LINE (" Cycle telnet to get open out"); --&MT Cycle_telnet; Process_echoed_data; --&MT Cycle_telnet; -- Verify the open -- My_debug_io.put_line(" Data has been sent. Waiting to verify the open"); TEXT_IO.NEW_LINE; FOR Index IN Open_verification'RANGE LOOP Wait_for_telnet_to_receive_a_character; virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); -- My_debug_io.put (" Correct data is "); -- my_utilities.Output_byte_to_screen( my_utilities.Byte( Open_verification( Index ))); -- My_debug_io.put (" Received data was "); my_utilities.Output_byte_to_screen ( Next_telnet_character ); -- TEXT_IO.NEW_LINE; IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( Open_verification( Index ))) THEN My_debug_io.put_line (" Bad comparison "); Temp_Status := Telnet_link_failed; END IF; END LOOP; TEXT_IO.NEW_LINE; IF Temp_Status = Telnet_link_successful THEN virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( ASCII.CR )) THEN My_debug_io.put_line (" <CR> not found"); Temp_Status := Telnet_link_failed; ELSE NULL; -- My_debug_io.put_line (" <CR> was found"); END IF; END IF; -- My_debug_io.put_line (" Done with open"); IF Temp_Status = Telnet_link_successful THEN -- My_debug_io.put_line (" Open was ok"); Verify_suppress_telnet_go_ahead_request( Temp_Status ); ELSE NULL; -- My_debug_io.put_line (" Open was bad"); END IF; STATUS := TEMP_STATUS ; EXCEPTION WHEN OTHERS => MY_DEBUG_IO.PUT_LINE (" UNKNOWN ERROR IN OPEN_TELNET_LINK"); RAISE; END OPEN_TELNET_LINK; PROCEDURE Close_telnet_link ----------------- ( Status : OUT Telnet_status_spec; Argument : IN Ftp_types.argument_list ) IS ----------------------------------------------------------------- -- -- RFC 765 Spec References: -- p. 7: It is the responsibility of the server to close -- the telnet connection at the request of the user. -- -- This procedure closes the telnet connection between the user- -- and server-pi. -- ----------------------------------------------------------------- Close_request : CONSTANT STRING(1..2) := "@c"; Close_verification : CONSTANT STRING(1..17) := "connection closed"; Temp_Status : Telnet_Status_Spec; BEGIN Temp_Status := Telnet_link_successful; -- Send the close request -- My_debug_io.put_line (" Loading the close request"); FOR Index IN Close_request'RANGE LOOP virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( Close_request( Index )))); END LOOP; -- My_debug_io.put_line (" Sending a <CR> to telnet"); virtual_terminal.Send_char_to_telnet (1, BIT_COUNT_8_TYPE(my_utilities.Byte(Ascii.cr))); dec_tn_tasks.tn.go ; -- tell telnet it has input to process --&MT Cycle_telnet; -- Verify the close Process_echoed_data; -- My_debug_io.put_line (" Verifing the close request"); FOR Index IN Close_verification'RANGE LOOP virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( Close_verification( Index ))) THEN My_debug_io.put_line (" Bad comparison during close"); Temp_Status := Telnet_link_failed; END IF; END LOOP; virtual_terminal.Get_next_character_from_telnet ( 1, Next_telnet_character ); IF BIT_COUNT_16_TYPE(Next_telnet_character) /= BIT_COUNT_16_TYPE(my_utilities.Byte( ASCII.CR )) THEN Temp_Status := Telnet_link_failed; END IF; -- Test for dangling data -- My_debug_io.put_line (" Checking for extra data"); IF virtual_terminal.There_are_characters_in_printer_buffer(1) THEN Temp_Status := Telnet_link_failed; END IF; -- My_debug_io.put_line (" Done with close request"); -- IF Temp_Status = Telnet_link_successful THEN -- My_debug_io.put_line (" Close was ok"); -- ELSE -- My_debug_io.put_line (" Close was bad"); -- END IF; Status := Temp_Status; EXCEPTION WHEN OTHERS => My_debug_io.put_line (" Unknown error in Close_telnet_Link "); RAISE; END Close_telnet_link; PROCEDURE LOAD_TELNET_TRANSMISSION_BUFFER ------------------------------- ( Status : OUT Telnet_status_spec; Input_length : IN Bit_Count_32_Type; Input_string : IN Command_types.command_string_spec ; Argument : IN Ftp_types.argument_list ) IS ------------------------------------------------------------ -- -- This procedure transfers a string to the telnet queue -- returns to the caller when a null character is encountered. -- -- It may be used by either the user or server ftp system -- because the respective telnets will know the location -- of their transmission buffers. -- -- Input_string has the 4 letter command string; -- Argument has the required arguments for the command; -- Input_length has length of command at beginning of Input_string -- ------------------------------------------------------------ Temp_Status : Telnet_Status_Spec; Argument_index : BIT_COUNT_16_TYPE := Argument'FIRST; --&MT My_input_length : BIT_COUNT_16_TYPE := BIT_COUNT_16_TYPE(Input_length) ; My_input_length : BIT_COUNT_32_TYPE := Input_length ; My_input_string : Command_types.command_string_spec := Input_string; -- My_input_string is a local data field for building the data stream -- to be send to telnet. PROCEDURE Load_argument_into_telnet_string_without_command IS BEGIN -- MY_DEBUG_IO.PUT_LINE (" Loading argument only"); FOR Index IN My_input_string'RANGE LOOP IF Ftp_types.end_of_argument( Argument( Argument_index )) THEN My_input_string( Index ) := ' '; -- Make last char a ' ' or get cmd dies! EXIT; ELSE -- Get the next byte from the argument My_input_string( Index ) := Argument( Argument_index ); Argument_index := Argument_index + 1; --pnts to nxt chr END IF; END LOOP; END Load_argument_into_telnet_string_without_command; PROCEDURE Load_argument_into_telnet_string_after_command IS BEGIN -- MY_DEBUG_IO.PUT_LINE (" Loading argument after command"); -- Load a ' ' after the command and before the argument My_input_string( My_input_length + 1) := ' '; FOR Index IN ( My_input_length + 2)..Input_string'LAST LOOP IF Ftp_types.end_of_argument( Argument( Argument_index )) THEN My_input_string( Index ) := ' '; -- Make last char a ' ' or get cmd dies! EXIT; ELSE My_input_string( Index ) := Argument( Argument_index ); Argument_index := Argument_index + 1; END IF; END LOOP; END Load_argument_into_telnet_string_after_command; BEGIN -- My_debug_io.put_line (" Setting up the telnet command string"); Temp_Status := Telnet_link_successful; IF Input_length = 0 THEN -- No command was sent; just an argument! Load_argument_into_telnet_string_without_command; ELSE -- A command was in input_string; load after command ! Load_argument_into_telnet_string_after_command; END IF; -- -- Command and argument in My_input_string; so load the telnet buffer -- -- TEXT_IO.NEW_LINE; -- FOR INDEX IN My_input_string'RANGE LOOP -- my_utilities.Output_byte_to_screen( my_utilities.Byte( My_input_string( Index ))); -- END LOOP; -- TEXT_IO.NEW_LINE; -- My_debug_io.put_line (" Loading the telnet buffer"); -- My_debug_io.put ("*"); FOR Index IN My_input_string'RANGE LOOP IF My_input_string ( INDEX ) = ASCII.NUL THEN -- Send the <CR> terminator virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( Ascii.cr ))); dec_tn_tasks.tn.go ; -- tell telnet it has input to process EXIT; ELSE virtual_terminal.Send_char_to_telnet( 1, BIT_COUNT_8_TYPE(my_utilities.Byte( My_input_string( Index )))); -- my_utilities.Output_byte_to_screen( my_utilities.Byte( My_input_string( Index ))); END IF; END LOOP; -- My_debug_io.put_line ("*"); -- My_debug_io.put_line (" Done loading the buffer"); --&MT Cycle_telnet; Process_echoed_data; --&MT Cycle_telnet; STATUS := TEMP_STATUS ; EXCEPTION WHEN OTHERS => MY_DEBUG_IO.PUT_LINE (" Unknown error in Load_telnet_xmit_buffer"); RAISE; END LOAD_TELNET_TRANSMISSION_BUFFER; PROCEDURE GET_DATA_FROM_TELNET_BUFFER --------------------------- ( STATUS : OUT TELNET_STATUS_SPEC; TELNET_DATA : OUT COMMAND_TYPES.COMMAND_STRING_SPEC )IS ----------------------------------------------------------------- -- -- This procedure gets telnet data from telnet, -- performs any required transformations, and then passes it back -- as a fixed length string; null padding if necessary. -- ----------------------------------------------------------------- Temp_Status : Telnet_Status_Spec; BEGIN -- My_debug_io.put_line (" Getting data from telnet buffer"); -- My_debug_io.put ("*"); Temp_Status := Telnet_link_successful; FOR Index IN Telnet_data'RANGE LOOP Wait_for_telnet_to_receive_a_character; virtual_terminal.Get_next_character_from_telnet( 1, Next_telnet_character ); IF BIT_COUNT_16_TYPE(next_telnet_character) = BIT_COUNT_16_TYPE(my_utilities.Byte( ASCII.CR )) THEN -- MY_DEBUG_IO.PUT_LINE (" <CR> found"); Telnet_data( Index ) := ' '; EXIT; ELSE -- MY_DEBUG_IO.PUT_LINE (" Loading byte into telnet data"); Telnet_data( Index ) := my_utilities.Char( BIT_COUNT_16_TYPE(Next_telnet_character )); END IF; -- text_io.new_line; -- my_utilities.Output_byte_to_screen( my_utilities.Byte( Telnet_data( Index ))); -- MY_DEBUG_IO.PUT_LINE(" was the last character received"); END LOOP; -- My_debug_io.put_line ("*"); -- My_debug_io.put_line (" Done getting data"); --&MT Cycle_telnet; -- Let the telnet go aheads get through Status := Temp_Status; EXCEPTION WHEN OTHERS => My_debug_io.put_line(" Unknown error in Get_data_from_telnet_buffer"); RAISE; END GET_DATA_FROM_TELNET_BUFFER; FUNCTION TELNET_FAILED ------------- ( STATUS : IN TELNET_STATUS_SPEC ) RETURN BOOLEAN IS -- -- This function is used to test the return status of a telnet command. -- BEGIN IF STATUS = TELNET_LINK_FAILED THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END TELNET_FAILED; FUNCTION TELNET_WAS_SUCCESSFUL --------------------- ( STATUS : IN TELNET_STATUS_SPEC ) RETURN BOOLEAN IS -- -- This function is used to test the return status of a telnet command. -- BEGIN IF STATUS = TELNET_LINK_SUCCESSFUL THEN RETURN TRUE; ELSE RETURN FALSE; END IF; END TELNET_WAS_SUCCESSFUL; BEGIN NULL; EXCEPTION WHEN OTHERS => MY_DEBUG_IO.PUT_LINE(" Unknown exception in ftp_telnet"); RAISE; END FTP_TELNET ; --:::::::::::::: --ftpcnvcmd_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01076-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPCNVCMD_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPCNVCMD AUTHOR : MARK VOLPE -- 5/16/85 9:50 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 8:27 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 9:55 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH TEXT_IO; WITH Command_types, Ftp_types, Ftp_terminal_driver; PACKAGE Ftp_convert_command IS TYPE Return_status_spec IS PRIVATE; -- -- Specifies completion status of convert_command_to_enumerated_type -- PROCEDURE Convert_command_to_enumerated_type ( STATUS : OUT Return_status_spec ; Word : IN Command_types.command_string_spec; Command : OUT Ftp_types.valid_command_spec ) ; -- -- This procedure converts the input string to an enumerated type -- FUNCTION Command_found ( Status : IN Return_status_spec ) RETURN BOOLEAN; -- -- This function tests the completion status of -- convert_command_to_enumerated_type -- PRIVATE TYPE Return_status_spec IS ( Conversion_found, No_conversion_found ); END Ftp_convert_command; --:::::::::::::: --ftpcnvcmd.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01077-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPCNVCMD.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPCNVCMD AUTHOR : MARK VOLPE -- 5/16/85 9:50 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 8:27 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 10:04 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY Ftp_convert_command IS --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); Array_start : CONSTANT BIT_COUNT_16_TYPE := Ftp_types.valid_command_spec'POS( Ftp_types.valid_command_spec'FIRST ); Array_end : CONSTANT BIT_COUNT_16_TYPE := Ftp_types.valid_command_spec'POS( Ftp_types.valid_command_spec'LAST ); TYPE Conversion_array_spec IS RECORD Command_string : Command_types.command_string_spec; Command_type : Ftp_types.valid_command_spec; END RECORD; Conversion_array : ARRAY(Array_start .. Array_end) OF Conversion_array_spec; PROCEDURE Convert_command_to_enumerated_type ( Status : OUT Return_status_spec ; Word : IN Command_types.command_string_spec; Command : OUT Ftp_types.valid_command_spec ) IS BEGIN Status := No_conversion_found; Command := Ftp_types.invalid_command; FOR Index IN Conversion_array'RANGE LOOP IF Conversion_array( Index ).command_string(1..4) = Word(1..4) THEN Command := Conversion_array( Index ).command_type; Status := Conversion_found; EXIT; END IF; END LOOP; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Convert_command_to_enumerated_type"); RAISE; END Convert_command_to_enumerated_type; FUNCTION Command_found ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Conversion_found THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Command_found"); RAISE; END Command_found; BEGIN FOR Index IN Conversion_array'RANGE LOOP Conversion_array( Index ).command_string := COMMAND_TYPES.NULL_COMMAND_STRING ; CONVERSION_ARRAY( Index ).command_type := Ftp_types.valid_command_spec'VAL( Index ); END LOOP; Conversion_array( Array_start + 0 ).command_string(1..5) := "CALL "; Conversion_array( Array_start + 1 ).command_string(1..5) := "CLOS "; Conversion_array( Array_start + 2 ).command_string(1..5) := "EXIT "; Conversion_array( Array_start + 3 ).command_string(1..5) := "NOOP "; Conversion_array( Array_start + 4 ).command_string(1..5) := "HELP "; Conversion_array( Array_start + 5 ).command_string(1..5) := "STRU "; Conversion_array( Array_start + 6 ).command_string(1..5) := "TYPE "; Conversion_array( Array_start + 7 ).command_string(1..5) := "MODE "; Conversion_array( Array_start + 8 ).command_string(1..5) := "PORT "; Conversion_array( Array_start + 9 ).command_string(1..5) := "QUIT "; Conversion_array( Array_start +10 ).command_string(1..5) := "USER "; Conversion_array( Array_start +11 ).command_string(1..5) := "PASS "; Conversion_array( Array_start +12 ).command_string(1..5) := "STOR "; Conversion_array( Array_start +13 ).command_string(1..5) := "RETR "; Conversion_array( Array_start +14 ).COMMAND_STRING(1..5) := "REPL "; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in FTP_convert_command"); RAISE; END Ftp_convert_command; --:::::::::::::: --ftprcvutl_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01082-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRCVUTL_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftprcvutl AUTHOR : MARK VOLPE -- 5/16/85 10:10 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 8:36 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 10:34 : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); --&MT The following line was added to support the use of integer_io WITH TEXT_IO; WITH My_debug_io; WITH Command_types, Ftp_types, Ftp_terminal_driver, Ftp_convert_command; PACKAGE Ftp_rcv_utils IS Logic_error : EXCEPTION; TYPE Return_status_spec IS PRIVATE; FUNCTION Valid_command_found ( Status : IN Return_status_spec ) RETURN BOOLEAN; PROCEDURE Get_command_from_command_string ( Return_status : OUT Return_status_spec; Command_string : IN Command_types.command_string_spec; Output_command : OUT Ftp_types.valid_command_spec; Argument : OUT Ftp_types.argument_list ); ----------------------------------------------------------------- -- -- This procedure checks the command string for syntax -- and returns an enummerated_value for the command. After the -- command has been determined, any arguements that are present -- are checked in addition to checking for required arguments. -- If an unrecognized command has been entered or invalid arguments -- were entered then 'COMMAND_INVALID' is returned. Arguments are -- returned as character strings. Abbreviated predefined parameters -- are translated into unique character strings so that upper level -- procedures do not need to test for shortened forms of these -- parameters. -- ----------------------------------------------------------------- FUNCTION Argument_list_is_valid ( Status : IN Return_status_spec ) RETURN BOOLEAN; FUNCTION Argument_list_is_invalid ( Status : IN Return_status_spec ) RETURN BOOLEAN; FUNCTION One_parameter_is_missing ( Status : IN Return_status_spec ) RETURN BOOLEAN; FUNCTION Two_parameters_are_missing ( Status : IN Return_status_spec ) RETURN BOOLEAN; FUNCTION Optional_parameter_was_omitted ( Status : IN Return_status_spec ) RETURN BOOLEAN; PRIVATE TYPE RETURN_STATUS_SPEC IS ( Word_found, No_more_data_in_command_string, Parameter_found, Parameter_expected , Valid_argument_list, Invalid_argument_list , One_parameter_missing, Two_parameters_missing, Optional_parameter_omitted, Invalid_reply, Valid_command, Command_invalid ); END Ftp_rcv_utils; --:::::::::::::: --ftprcvutl.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01083-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRCVUTL.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftprcvutl AUTHOR : MARK VOLPE -- 5/16/85 10:10 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 8:36 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 10:45 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY Ftp_rcv_utils IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); FUNCTION Argument_list_is_valid ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Valid_argument_list THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Argument_list_is_valid ; FUNCTION Argument_list_is_invalid ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Invalid_argument_list THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Argument_list_is_invalid ; FUNCTION One_parameter_is_missing ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = One_parameter_missing THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END One_parameter_is_missing; FUNCTION Two_parameters_are_missing ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Two_parameters_missing THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Two_parameters_are_missing; FUNCTION Optional_parameter_was_omitted ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Optional_parameter_omitted THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Optional_parameter_was_omitted; FUNCTION Valid_command_found ( Status : IN Return_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Valid_command THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Valid_command_found"); RAISE; END Valid_command_found; PROCEDURE Get_next_word_from_command_string ( Status : OUT Return_status_spec; Command_string : IN Command_types.command_string_spec; Next_word : OUT Command_types.command_string_spec; --&MT Word_length : OUT BIT_COUNT_16_TYPE; Word_length : OUT BIT_COUNT_32_TYPE; --&MT Location_pointer : IN OUT BIT_COUNT_16_TYPE ) IS Location_pointer : IN OUT BIT_COUNT_32_TYPE ) IS --&MT Initial_location : BIT_COUNT_16_TYPE := Location_pointer; Initial_location : BIT_COUNT_32_TYPE := Location_pointer; --&MT End_location : BIT_COUNT_16_TYPE ; End_location : BIT_COUNT_32_TYPE ; --&MT temp_word_length : BIT_COUNT_16_TYPE; temp_word_length : BIT_COUNT_32_TYPE; BEGIN -- -- Scan the input string for a nonblank char, this indicates -- the start of actual data -- WHILE (NOT Command_types.end_of_command( Command_string(Location_pointer))) AND THEN (bit_count_16_type(Location_pointer) <= Command_types.max_command_string_length) AND THEN (Command_string( Location_pointer ) = ' ' ) LOOP Location_pointer := Location_pointer + 1; END LOOP; -- -- Test for end of line. (Ex. no data on line ) -- IF Command_types.end_of_command( Command_string ( Location_pointer ) ) OR ELSE bit_count_16_type(Location_pointer) = Command_types.max_command_string_length THEN Status := No_more_data_in_command_string; -- My_debug_io.put_line ( " Normal end of command found "); RETURN; END IF; -- -- Save the new location_pointer as the starting position -- Initial_location := Location_pointer; -- -- Scan the characters from the initial_location -- towards the end of the string until a delimeter is -- found. WHILE (NOT Command_types.end_of_command( Command_string( Location_pointer))) AND THEN (bit_count_16_type(Location_pointer) < Command_types.max_command_string_length ) AND THEN ( Command_string( Location_pointer ) /= ' ' ) LOOP Location_pointer := Location_pointer + 1; END LOOP; -- -- See what caused us to fall out of the loop -- IF Command_string( Location_pointer ) = ' ' THEN -- -- SAVE END POINTER FOR LATER -- End_location := Location_pointer - 1; -- -- How big was the word we found? -- Temp_Word_length := End_location - Initial_location + 1; Next_word( Command_types.command_string_spec'FIRST.. Command_types.command_string_spec'FIRST + TEMP_WORD_LENGTH-1) := Command_string( INITIAL_LOCATION .. End_location ); Status := Word_found; ELSIF Command_types.end_of_command(command_string( Location_pointer )) THEN Status := No_more_data_in_command_string; -- My_debug_io.put_line( " 2 No more data in command string"); ELSIF bit_count_16_type(Location_pointer) >= Command_types.max_command_string_length THEN Status := No_more_data_in_command_string; -- My_debug_io.put_line( " 3 No more data in command string"); ELSE -- It better never get here or I goofed up really bad! -- RAISE Logic_error; END IF; -- Save the word just found -- Update the location_pointer. word_length := temp_word_length ; EXCEPTION WHEN Logic_error => Ftp_terminal_driver.output_message_with_new_line (" ***** LOGIC ERROR in Get_next_word *****"); RAISE; WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown error in Get_Next_word"); RAISE; END ; PROCEDURE Get_parameter ( Status : OUT Return_status_spec; Command : IN Ftp_types.valid_command_spec; Command_string : IN Command_types.command_string_spec; Argument : OUT Ftp_types.argument_list ; --&MT Length : OUT BIT_COUNT_16_TYPE; Length : OUT BIT_COUNT_32_TYPE; --&MT Command_string_location : IN OUT BIT_COUNT_16_TYPE ) IS Command_string_location : IN OUT BIT_COUNT_32_TYPE ) IS ----------------------------------------------------------------- -- -- This procedure gets a parameter from the command_string and stores -- it in the argument list array -- -- Return_status = PARAMETER_FOUND OR -- PARAMETER_EXPECTED ----------------------------------------------------------------- Argument_index: BIT_COUNT_16_TYPE := Argument'FIRST; Word : Command_types.command_string_spec := Command_types.null_command_string; temp_status : return_status_spec; --&MT temp_length : bit_count_16_type; temp_length : bit_count_32_type; BEGIN -- -- Get a parameter from the command string -- Get_next_word_from_command_string ( temp_status, Command_string, Word, temp_length, Command_string_location); IF temp_status = Word_found THEN temp_status := Parameter_found; FOR Index IN Word'FIRST .. ( Word'FIRST + temp_length - 1) LOOP -- -- This HAS to be a loop because of -- the type conversion !!! -- Argument ( Argument_index ) := Ftp_types.argument_list_unit'( Word( Index )); Argument_index := Argument_index + 1; END LOOP; ELSE temp_status := Parameter_expected; RETURN; END IF; status := temp_status; length := temp_length; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Get_Parameter"); RAISE; END Get_parameter; PROCEDURE Process_argument_list ( Status : OUT Return_status_spec; Command : IN Ftp_types.valid_command_spec; Command_string : IN Command_types.command_string_spec; Argument : OUT Ftp_types.argument_list; --&MT Location : IN OUT BIT_COUNT_16_TYPE ) IS Location : IN OUT BIT_COUNT_32_TYPE ) IS ----------------------------------------------------------------- -- -- This procedure processes the parameter list for the different -- commands. -- -- Status = VALID_ARGUMENT_LIST OR -- INVALID_ARGUMENT_LIST ----------------------------------------------------------------- --&MT Start_location : BIT_COUNT_16_TYPE := Location; Start_location : BIT_COUNT_32_TYPE := Location; --&MT End_location : BIT_COUNT_16_TYPE := Location; End_location : BIT_COUNT_32_TYPE := Location; --&MT Argument_length : BIT_COUNT_16_TYPE ; Argument_length : BIT_COUNT_32_TYPE ; --&MT Temp_argument_length: BIT_COUNT_16_TYPE ; Temp_argument_length: BIT_COUNT_32_TYPE ; Temp_argument : Ftp_types.argument_list := Ftp_types.null_argument; temp_status : return_status_spec; temp_arg : ftp_types.argument_list; BEGIN temp_arg:= Ftp_types.null_argument; -- -- Location is pointing to the first character after -- the end of the command. It may be a null or a ' ', -- and location may = max_command_length. -- CASE Command IS WHEN Ftp_types.stor_command | Ftp_types.retr_command => -- -- Takes 2 arguments -- Get_parameter ( temp_status, Command, Command_string, temp_arg, Argument_length, Location ); IF temp_status = Parameter_found THEN Get_parameter ( temp_status, Command, Command_string, Temp_argument, Temp_argument_length, Location ); IF temp_status = Parameter_found THEN temp_status := Valid_argument_list; temp_arg( temp_arg'FIRST + bit_count_16_type(Argument_length)) := Ftp_types.argument_list_unit'(' '); temp_arg( temp_arg'FIRST + bit_count_16_type(Argument_length) + 1 .. temp_arg'FIRST + bit_count_16_type(Argument_length) + bit_count_16_type(Temp_argument_length )) := Temp_argument ( Temp_argument'first.. Temp_argument'first + bit_count_16_type(Temp_argument_length) - 1); ELSE temp_status := One_parameter_missing; -- My_debug_io.put_line -- (" ~~ Second parameter expected ~~"); END IF; ELSE temp_status := Two_parameters_missing; -- My_debug_io.PUT_LINE(" ~~ Parameter expected ~~"); END IF; WHEN Ftp_types.type_command => -- -- Takes 1 or 2 arguments -- Get_parameter ( temp_status, Command, Command_string, temp_arg, Argument_length, Location ); IF temp_status = Parameter_found THEN -- -- Next parameter in argument -- store it for later -- -- Remember: Only the first character -- Temp_argument( Temp_argument'FIRST) := temp_arg( temp_arg'FIRST); Temp_argument( Temp_argument'FIRST + 1) := Ftp_types.argument_list_unit'(' '); -- -- Get the carriage control field if there -- Get_parameter ( temp_status, Command, Command_string, temp_arg, Argument_length, Location); IF temp_status = Parameter_found THEN -- -- Next parameter in argument -- store it for later -- -- Remember: Only the first character -- temp_status := Valid_argument_list; Temp_argument( Temp_argument'FIRST + 2) := temp_arg( temp_arg'FIRST); ELSE -- -- Use the default carriage control -- temp_status := Optional_parameter_omitted; Temp_argument( Temp_argument'FIRST + 2):= Ftp_types.default_carriage_control; -- My_debug_io.Put_line -- (" ~~ Using default carriage control ~~"); END IF; ELSE temp_status := Invalid_argument_list; -- My_debug_io.Put_line(" ~~ Parameter list expected ~~"); END IF; -- -- Store the new argument list -- temp_arg := Temp_argument; WHEN Ftp_types.stru_command | Ftp_types.mode_command => -- -- Takes 1 argument ( 1st character only ) -- Get_parameter ( temp_status, Command, Command_string, temp_arg, Argument_length, Location); IF temp_status = Parameter_found THEN temp_status := Valid_argument_list; temp_arg( bit_count_16_type(Argument_length) + 1 ) := (' '); Temp_argument( Temp_argument'FIRST) := temp_arg( temp_arg'FIRST); temp_arg := Temp_argument; ELSE temp_status := One_parameter_missing; -- My_debug_io.PUT_LINE(" ~~ Parameter expected ~~"); END IF; WHEN Ftp_types.call_command | Ftp_types.clos_command | Ftp_types.port_command | Ftp_types.pass_command => -- -- Takes 1 argument -- Get_parameter ( temp_status, Command, Command_string, temp_arg, Argument_length, Location); IF temp_status = Parameter_found THEN temp_status := Valid_argument_list; temp_arg( bit_count_16_type(Argument_length) + 1) := (' '); ELSE temp_status := One_parameter_missing; -- My_debug_io.PUT_LINE(" ~~ Parameter expected ~~"); END IF; WHEN Ftp_types.noop_command | Ftp_types.exit_command | Ftp_types.quit_command => -- -- Takes 0 arguments -- temp_status := Valid_argument_list; -- force extra parameters test WHEN Ftp_types.user_command | Ftp_types.help_command => -- -- Takes 0 or 1 arguments -- Get_parameter ( temp_status, Command, Command_string, temp_arg, Argument_length, Location); IF temp_status = Parameter_found THEN temp_status := Valid_argument_list; ELSE temp_status := Optional_parameter_omitted; -- MY_DEBUG_IO.PUT_LINE -- (" ~~ Optional parameter list excluded ~~"); END IF; WHEN Ftp_types.reply_command => temp_status := Valid_argument_list; -- Force test for extra parameters. WHEN OTHERS => temp_status := Invalid_argument_list; -- MY_DEBUG_IO.PUT_LINE -- (" Illegal command passed to Process_parameter_List"); END CASE; -- -- All expected parameters have been processed; -- Test for extra parameters. -- IF temp_status = Valid_argument_list THEN DECLARE Local_status : Return_status_spec; BEGIN Get_parameter ( Local_status, Command, Command_string, Temp_argument, Argument_length, Location); IF Local_status = Parameter_expected THEN NULL; ELSE Status := Invalid_argument_list; -- My_debug_io.PUT_LINE(" ~~ Extra parameters ignored ~~"); END IF; END; ELSE NULL; -- Leave the status code as it was END IF; status := temp_status; argument := temp_arg; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown error in Process_Argument_List"); RAISE; END Process_argument_list; PROCEDURE Get_command_from_command_string ( Return_status : OUT Return_status_spec; Command_string : IN Command_types.command_string_spec; Output_command : OUT Ftp_types.valid_command_spec; Argument : OUT Ftp_types.argument_list ) IS ----------------------------------------------------------------- -- -- This procedure checks the command string for syntax -- and returns an enummerated_value for the command. After the -- command has been determined, any arguements that are present -- are checked in addition to checking for required arguments. -- If an unrecognized command has been entered or invalid arguments -- were entered then 'COMMAND_INVALID' is returned. Arguments are -- returned as character strings. Abbreviated predefined parameters -- are translated into unique character strings so that upper level -- procedures do not need to test for shortened forms of these -- parameters. -- ----------------------------------------------------------------- Word : Command_types.command_string_spec := Command_types.null_command_string; --&MT Word_length : BIT_COUNT_16_TYPE := 0; Word_length : BIT_COUNT_32_TYPE := 0; --&MT Location : BIT_COUNT_16_TYPE := 1; Location : BIT_COUNT_32_TYPE := 1; Conversion_status: Ftp_convert_command.return_status_spec; temp_return_status : return_status_spec; temp_output_command : ftp_types.valid_command_spec; BEGIN Get_next_word_from_command_string ( temp_return_status, Command_string, Word, Word_length, Location); IF temp_return_status = Word_found THEN -- -- CONVERT TO ENUMERATED TYPE -- Ftp_convert_command.convert_command_to_enumerated_type ( Conversion_status, Word, temp_output_command ); IF Ftp_convert_command.command_found( Conversion_status ) THEN temp_return_status := Valid_command; Process_argument_list ( temp_return_status, temp_output_command, Command_string, Argument, Location); ELSE temp_return_status := Command_invalid; -- MY_DEBUG_IO.PUT_LINE (" Invalid command"); END IF; ELSE temp_return_status := Command_invalid; -- MY_DEBUG_IO.PUT_LINE(" No command found"); END IF; return_status := temp_return_status; output_command := temp_output_command; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Get_Command_From_Command_String"); RAISE; END Get_command_from_command_string; BEGIN NULL; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in ftp_rcv_utils"); RAISE; END Ftp_rcv_utils; --:::::::::::::: --ftpcmdutl_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01074-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPCMDUTL_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftpcmdutl AUTHOR : MARK VOLPE -- 5/16/85 2:35 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 10:26 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 11:17 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); with My_debug_io, Command_types, Ftp_types, Ftp_terminal_driver, Ftp_rcv_utils, Ftp_telnet; --&MT THE FOLLOWING LINE WAS ADDED TO PERMIT CALLING TO INTEGER_IO IN BODY PART with TEXT_IO; --&MT THE FOLLOWING LINE WAS ADDED TO ENABLE THE DEC COMPILER TO CHECK FOR --&MT EQUALITY BETWEEN TWO ENUMERATED TYPES FOUND IN FTP_TYPES use ftp_types; PACKAGE Ftp_command_utilities IS ---------------------------------------------------------------------- -- -- This package contains procedures that are used to get a command or reply -- and its arguments from telnet, or the keyboard. -- ---------------------------------------------------------------------- TYPE Command_status_spec IS PRIVATE; TYPE Transmission_status_spec Is PRIVATE; FUNCTION Transmission_successful ( Xmit_status : IN Transmission_status_spec ) RETURN BOOLEAN; PROCEDURE Send_command_over_telnet ( Status : OUT Transmission_status_spec; Command : IN Ftp_types.valid_command_spec; Argument : IN Ftp_types.argument_list ) ; ---------------------------------------------------------------------- -- -- This procedure transmitts a command and its arguments, -- via telnet, from the user system to the server system -- ---------------------------------------------------------------------- PROCEDURE Get_command_from_telnet ( Command_status : OUT Command_status_spec; Command : OUT Ftp_types.valid_command_spec; Argument : OUT Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure gets a command and any arguments from the -- user pi via telnet and returns them to the calling program. -- ---------------------------------------------------------------------- PROCEDURE Get_command_from_keyboard ( Command_status : OUT Command_status_spec; Command : OUT Ftp_types.valid_command_spec; Argument : OUT Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure gets a command and any arguments from the -- user via the keyboard and returns them to the calling -- program. -- ---------------------------------------------------------------------- PROCEDURE Get_first_argument_from_argument_list ( Argument : IN Ftp_types.argument_list ; Parameter : OUT Ftp_types.argument_list); ---------------------------------------------------------------------- -- -- This procedure gets the first argument from the argument -- list. No status is returned because the argument list -- has already been validated when it was built. -- ---------------------------------------------------------------------- PROCEDURE Get_second_argument_from_argument_list ( Argument : IN Ftp_types.argument_list ; Parameter : OUT Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure gets the second argument from the argument -- list. No status is returned because the argument list -- has already been validated when it was built. -- ---------------------------------------------------------------------- FUNCTION Command_is_valid ( Status : IN Command_status_spec ) RETURN BOOLEAN; ---------------------------------------------------------------------- -- -- This function tests to see if a valid command was returned -- ---------------------------------------------------------------------- FUNCTION Argument_list_is_valid ( Status : IN Command_status_spec ) RETURN BOOLEAN; ---------------------------------------------------------------------- -- -- This function tests to see if the received argument list was valid -- ---------------------------------------------------------------------- FUNCTION Argument_list_is_invalid ( Status : IN Command_status_spec ) RETURN BOOLEAN; ---------------------------------------------------------------------- -- -- This function tests to see if the received argument list was invalid -- ---------------------------------------------------------------------- FUNCTION One_parameter_is_missing ( Status : IN Command_status_spec ) RETURN BOOLEAN; ---------------------------------------------------------------------- -- -- This function tests to see if one parameter was missing -- ---------------------------------------------------------------------- FUNCTION Two_parameters_are_missing ( Status : IN Command_status_spec ) RETURN BOOLEAN; ---------------------------------------------------------------------- -- -- This function tests to see if two paramters are missing -- ---------------------------------------------------------------------- PRIVATE TYPE Transmission_status_spec IS ( Xmit_successful, Xmit_failed ); TYPE Command_status_spec IS ( Valid_command, Invalid_command, Valid_argument_list, Invalid_argument_list, One_parameter_missing, Two_parameters_missing, Optional_parameter_omitted, Extra_parameters_received ); END Ftp_command_utilities ; --:::::::::::::: --ftpcmdutl.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01075-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPCMDUTL.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftpcmdutl AUTHOR : MARK VOLPE -- 5/16/85 2:35 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 10:26 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 11:26 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY Ftp_command_utilities IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); FUNCTION Transmission_successful ( Xmit_status : IN Transmission_status_spec ) RETURN BOOLEAN IS BEGIN IF Xmit_status = Xmit_successful THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Transmission_successful"); RAISE; END Transmission_successful; PROCEDURE Send_command_over_telnet ( Status : OUT Transmission_status_spec; Command : IN Ftp_types.valid_command_spec; Argument : IN Ftp_types.argument_list ) IS ------------------------------------------------------------ -- -- This procedure is used by the user ftp system and is responsible -- for interfacing to telnet. -- -- It accepts a command and an argument. The command is an -- enumerated type. The argument is a string and may be a null -- string if the command does not require any arguments. -- Using a case statement to determine the command, the correct -- character sequence is loaded into the telnet buffer and then sent -- to the listening server or host. -- Null characters are not transmitted and indicate the end of data. -- ------------------------------------------------------------ Start : BIT_COUNT_16_TYPE := 5; Command_length : BIT_COUNT_32_TYPE; Argument_index : BIT_COUNT_16_TYPE := Argument'FIRST; Telnet_status : Ftp_telnet.telnet_status_spec; Command_string : Command_types.command_string_spec := Command_types.null_command_string; BEGIN Command_length := 4; CASE Ftp_types.valid_command_spec'( Command ) IS WHEN Ftp_types.noop_command => Command_string(1..4) := "NOOP"; WHEN Ftp_types.help_command => Command_string(1..4) := "HELP"; WHEN Ftp_types.stru_command => Command_string(1..4) := "STRU"; WHEN Ftp_types.type_command => Command_string(1..4) := "TYPE"; WHEN Ftp_types.mode_command => Command_string(1..4) := "MODE"; WHEN FTP_TYPES.PORT_COMMAND => Command_string(1..4) := "PORT"; WHEN Ftp_types.quit_command => Command_string(1..4) := "QUIT"; WHEN Ftp_types.user_command => Command_string(1..4) := "USER"; WHEN FTP_TYPES.PASS_COMMAND => Command_string(1..4) := "PASS"; WHEN Ftp_types.stor_command => Command_string(1..4) := "STOR"; WHEN FTP_TYPES.RETR_COMMAND => Command_string(1..4) := "RETR"; WHEN Ftp_types.reply_command => Start := 1; Command_length := 0; WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Can't send that command over telnet"); Status := Xmit_failed; Return; END CASE; -- My_debug_io.put_line (" ~~ Sending command ~~"); -- My_debug_io.put('*'); -- My_debug_io.put( Command_string ); -- My_debug_io.put_line ("*"); Ftp_telnet.load_telnet_transmission_buffer ( Telnet_status, Command_length, Command_string, Argument ); IF Ftp_telnet.telnet_was_successful ( Telnet_status ) THEN -- My_debug_io.put_line (" ~~ Command send successful ~~"); Status := Xmit_successful; ELSE -- My_debug_io.put_line (" ~~ Command send failed ~~"); Status := Xmit_failed; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_command_over_telnet"); RAISE; END Send_command_over_telnet; PROCEDURE Set_command_status ( Input_status : IN Ftp_rcv_utils.return_status_spec; Output_status: OUT Command_status_spec ) IS BEGIN IF Ftp_rcv_utils.argument_list_is_valid( Input_status ) THEN Output_status := Valid_argument_list; ELSIF Ftp_rcv_utils.one_parameter_is_missing( Input_status ) THEN Output_status := One_parameter_missing; ELSIF Ftp_rcv_utils.two_parameters_are_missing( Input_status ) THEN Output_status := Two_parameters_missing; ELSIF Ftp_rcv_utils.optional_parameter_was_omitted( Input_status ) THEN Output_status := Optional_parameter_omitted; ELSE OUTPUT_STATUS := INVALID_ARGUMENT_LIST; END IF; EXCEPTION WHEN OTHERS => RAISE; END Set_command_status; PROCEDURE Get_first_argument_from_argument_list ( Argument : IN Ftp_types.argument_list ; Parameter : OUT Ftp_types.argument_list ) IS Offset : BIT_COUNT_16_TYPE := Parameter'FIRST; BEGIN FOR Index IN Argument'RANGE LOOP IF Argument( Index ) = Ftp_types.argument_list_unit'(' ') THEN EXIT; ELSE Parameter( Offset ) := Argument( Index ); Offset := Offset + 1; END IF; END LOOP; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown error in get_first_parameter"); RAISE; END Get_first_argument_from_argument_list; PROCEDURE Get_second_argument_from_argument_list ( Argument : IN Ftp_types.argument_list ; Parameter: OUT Ftp_types.argument_list) is Offset : BIT_COUNT_16_TYPE := Parameter'FIRST; Start : BIT_COUNT_16_TYPE := 0; BEGIN -- -- SKIP FIRST PARAMETER -- FOR Index IN Argument'RANGE LOOP IF Argument( Index ) = ' ' THEN EXIT; ELSE Start := Index ; END IF; END LOOP; Start := Start + 2; -- -- GET THE SECOND PARAMETER -- FOR Index IN Start .. Argument'LAST LOOP IF Argument( Index ) = ' ' THEN EXIT; ELSE Parameter( Offset ) := Argument( Index ); Offset := Offset + 1; END IF; END LOOP; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown error in GET_SECOND_PARAMETER"); RAISE; END Get_second_argument_from_argument_list; PROCEDURE Validate_server_command ( Local_status : IN Ftp_rcv_utils.return_status_spec; Command_status : OUT Command_status_spec; Command : IN OUT Ftp_types.valid_command_spec ) IS BEGIN IF Ftp_rcv_utils.argument_list_is_valid( Local_status ) THEN Command_status := Valid_argument_list; ELSIF ( Command = Ftp_types.user_command) AND THEN ( Ftp_rcv_utils.optional_parameter_was_omitted( Local_status )) THEN Command_status := Valid_argument_list; ELSIF ( Command = Ftp_types.type_command ) AND THEN ( Ftp_rcv_utils.optional_parameter_was_omitted( Local_status )) THEN Command_status := Valid_argument_list; ELSIF ( Command = Ftp_types.help_command ) AND THEN ( Ftp_rcv_utils.optional_parameter_was_omitted( Local_status )) THEN Command_status := Valid_argument_list; ELSIF ( ( Command = Ftp_types.stor_command ) OR ELSE ( Command = Ftp_types.retr_command ) ) AND THEN ( Ftp_rcv_utils.one_parameter_is_missing( Local_status )) THEN Command_status := Valid_argument_list; ELSE Command_status := Invalid_argument_list; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown error in Validate_server_command"); RAISE; END Validate_server_command; PROCEDURE Get_command_from_telnet ( Command_status : OUT Command_status_spec; Command : OUT Ftp_types.valid_command_spec; Argument : OUT Ftp_types.argument_list ) IS Input_data_length : BIT_COUNT_16_TYPE ; Local_status : Ftp_rcv_utils.return_status_spec; Ftp_telnet_status : Ftp_telnet.telnet_status_spec; Input_data : Command_types.command_string_spec := Command_types.null_command_string; temp_command : ftp_types.valid_command_spec; BEGIN Ftp_telnet.get_data_from_telnet_buffer( Ftp_telnet_status, Input_data); -- My_debug_io.PUT_LINE (" Data from telnet is "); -- My_debug_io.PUT ('*'); -- My_debug_io.PUT ( INPUT_DATA ); -- My_debug_io.PUT_LINE ("*"); Ftp_rcv_utils.get_command_from_command_string ( Local_status, Input_data, temp_command, Argument ); Validate_server_command ( Local_status, Command_status, temp_command); command := temp_command; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Get_Command_From_Telnet"); Temp_command := Ftp_types.invalid_command; Command := Temp_command; RAISE; END Get_command_from_telnet; PROCEDURE Get_command_from_keyboard ( Command_status : OUT Command_status_spec; Command : OUT Ftp_types.valid_command_spec; Argument : OUT Ftp_types.argument_list ) IS Local_status : Ftp_rcv_utils.return_status_spec; Input_data : Command_types.command_string_spec := Command_types.null_command_string; BEGIN Ftp_terminal_driver.get_command_from_keyboard ( Input_data ); Ftp_rcv_utils.get_command_from_command_string ( Local_status, Input_data, Command, Argument ); Set_command_status ( Local_status, Command_status ); EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Get_Command_From_Keyboard"); RAISE; END Get_command_from_keyboard; FUNCTION Command_is_valid( Status : IN Command_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Valid_command THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Command_is_valid; FUNCTION Argument_list_is_valid ( Status : IN Command_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Valid_argument_list THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Argument_list_is_valid; FUNCTION One_parameter_is_missing ( Status : IN Command_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = One_parameter_missing THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END One_parameter_is_missing; FUNCTION Two_parameters_are_missing ( Status : IN Command_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Two_parameters_missing THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END TWO_PARAMETERS_ARE_MISSING; FUNCTION Argument_list_is_invalid ( Status : IN Command_status_spec ) RETURN BOOLEAN IS BEGIN IF Status = Valid_argument_list OR ELSE Status = Optional_parameter_omitted THEN RETURN FALSE; ELSE RETURN TRUE; END IF; EXCEPTION WHEN OTHERS => RAISE; END Argument_list_is_invalid; BEGIN NULL; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in FTP_COMMAND_UTILITIES"); RAISE; END Ftp_command_utilities ; --:::::::::::::: --mycnvt_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01120-100(-) -- E-Systems, Inc. August 07, 1985 -- -- MYCNVT_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : MYCNVT AUTHOR : MIKE THOMAS -- 5/17/85 8:06 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 10:55 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 11:45 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT WITH SYSTEM, UNCHECKED_CONVERSION; --&MT THE FOLLOWING LINE WAS ADDED TO ALLOW PACKAGE MYCNVT TO ACCESS TEXT_IO. WITH TEXT_IO; PACKAGE MY_CONVERSIONS IS --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING TELESOFT : PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); FUNCTION Char ( In_integer : BIT_COUNT_16_TYPE ) RETURN CHARACTER; FUNCTION Byte IS NEW Unchecked_conversion ( CHARACTER, BIT_COUNT_16_TYPE ); END MY_CONVERSIONS; --:::::::::::::: --mycnvt.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01121-100(-) -- E-Systems, Inc. August 07, 1985 -- -- MYCNVT.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : MYCNVT AUTHOR : MIKE THOMAS -- 5/17/85 8:06 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 10:55 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 11:48 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY MY_CONVERSIONS IS FUNCTION Convert_integer_to_character IS NEW Unchecked_conversion ( BIT_COUNT_16_TYPE, CHARACTER ); FUNCTION Char ( In_integer : BIT_COUNT_16_TYPE ) RETURN CHARACTER IS Byte_string : STRING (1..2); BEGIN Byte_string(1) := Convert_integer_to_character ( In_integer ); RETURN Byte_string(1); END CHAR; END MY_CONVERSIONS; --:::::::::::::: --ftplowio_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01080-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPLOWIO_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPLOWIO AUTHOR : MARK VOLPE -- 5/30/85 2:40 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/23/85 3:52 PM : mods to global variables --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io, My_utilities; WITH Ftp_terminal_driver, Command_types; --&MT THE FOLLOWING LINE SHOULD BE INCLUDED WHEN USING TELESOFT : --&MT WITH ASCII; WITH SYSTEM, SEQUENTIAL_IO, TEXT_IO, MY_CONVERSIONS; USE SYSTEM,TEXT_IO; --&MT THE FOLLOWING LINE SHOULD BE INCLUDED WHEN USING TELESOFT : --&MT USE INTEGER_IO; PACKAGE Ftp_low_level_io IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.BYTE; SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.UNSIGNED_BYTE; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT : PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PACKAGE SYSTEM_BYTE IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_8_TYPE); End_of_file : EXCEPTION; Error_closing_file : EXCEPTION; Error_creating_file : EXCEPTION; Error_opening_file : EXCEPTION; File_read_error : EXCEPTION; File_size_error : EXCEPTION; -- Couldn't get # of blks in file File_write_error : EXCEPTION; Record_size_error : EXCEPTION; -- Record too big --&MT SUBTYPE Block_index_spec IS BIT_COUNT_16_TYPE; SUBTYPE Block_index_spec IS BIT_COUNT_32_TYPE; TYPE Block_spec IS ARRAY(1..128) OF BIT_COUNT_8_TYPE; Block_size : CONSTANT BIT_COUNT_16_TYPE := Block_spec'LENGTH; --&MT Start_of_block : CONSTANT BIT_COUNT_16_TYPE := Block_spec'FIRST; Start_of_block : CONSTANT BIT_COUNT_32_TYPE := Block_spec'FIRST; --&MT End_of_block : BIT_COUNT_16_TYPE ; End_of_block : BIT_COUNT_32_TYPE ; Output_block : Block_spec; Input_block : Block_spec; TYPE Record_SPEC IS ARRAY (0..132) OF BIT_COUNT_8_TYPE ; -- contains record data --&MT Start_of_record : CONSTANT BIT_COUNT_16_TYPE := Record_spec'FIRST; Start_of_record : CONSTANT BIT_COUNT_32_TYPE := Record_spec'FIRST; --&MT End_of_record : BIT_COUNT_16_TYPE ; End_of_record : BIT_COUNT_32_TYPE ; Record_size : CONSTANT BIT_COUNT_16_TYPE := Record_spec'LENGTH; Input_record : Record_SPEC; Output_record : Record_SPEC; FUNCTION Current_data_is_eof_marker ( Data_byte : IN BIT_COUNT_8_TYPE ) RETURN BOOLEAN; FUNCTION Current_data_is_eor_marker ( Data_byte : IN BIT_COUNT_8_TYPE ) RETURN BOOLEAN; PROCEDURE Find_out_if_user_wants_data_echoed_to_screen_during_transfer; PROCEDURE Open_input_file ( File_name : IN STRING ); ---------------------------------------------------------------------- -- -- This procedure opens the file and sets the system up ready to get -- the first record -- -- Exceptions: Error_opening_file. -- NOTE: May raise Error_closing_file if an exception occurs while -- accessing the file after it has been opened but before the -- procedure returns to the calling routine. ---------------------------------------------------------------------- PROCEDURE Create_output_file ( File_name : IN STRING ); ---------------------------------------------------------------------- -- -- This procedure creates the file and sets the system up ready to -- store data. -- -- Exceptions: Error_creating_file. ---------------------------------------------------------------------- PROCEDURE Close_output_file; ---------------------------------------------------------------------- -- -- This procedure closes the output file -- -- Exceptions: Error_closing_file. ---------------------------------------------------------------------- PROCEDURE Close_input_file; ---------------------------------------------------------------------- -- -- This procedure closes a file -- -- Exceptions: Error_closing_file. ---------------------------------------------------------------------- PROCEDURE Write_record_to_output_file; ---------------------------------------------------------------------- -- -- This procedure writes the next record to the output file from -- output_record. -- -- Exceptions: End_of_file, File_write_error. ---------------------------------------------------------------------- PROCEDURE Read_record_from_input_file; ---------------------------------------------------------------------- -- -- This procedure gets the next record from the input file and stores -- it in Input_record. -- -- Exceptions: End_of_file, File_read_error. ---------------------------------------------------------------------- PROCEDURE Read_block_from_input_file; ---------------------------------------------------------------------- -- -- This procedure gets the next block from the specified file and stores -- it in Input_block. -- -- Exceptions: End_of_file, File_read_error. ---------------------------------------------------------------------- PROCEDURE Write_block_to_output_file; ---------------------------------------------------------------------- -- -- This procedure writes Output_block as the next block in the output_file -- -- Exceptions: File_write_error. ---------------------------------------------------------------------- END Ftp_low_level_io; --:::::::::::::: --ftplowio.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01081-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPLOWIO.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPLOWIO AUTHOR : MARK VOLPE -- 5/20/85 2:51 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/23/85 10:47 AM : mods for text_io from sequential_io -- 7/23/85 3:15 PM : mods for global variables -- 7:03 PM : changes to read record and read block -- 10:00 PM : look for cr in write block -- 7/24/85 1:45 AM : don't do new_line in write block, just the CR -- 2:32 AM : remove some debug stm PACKAGE BODY Ftp_low_level_io IS -- PACKAGE Ftp_io is new SEQUENTIAL_IO( BIT_COUNT_8_TYPE ); -- PACKAGE Ftp_io renames text_io; --&MT Block_index : BIT_COUNT_16_TYPE := Start_of_block; Block_index : BIT_COUNT_32_TYPE := Start_of_block; Data_echoing_is_desired : BOOLEAN := TRUE; -- Debugging Ending_index : BIT_COUNT_16_TYPE; Eof_indicator : BIT_COUNT_8_TYPE := 16#FF#; Eor_indicator : BIT_COUNT_8_TYPE := 16#0D#; Horizontal_tab : CONSTANT BIT_COUNT_8_TYPE := 16#09#; Input_file : TEXT_io.file_type; Input_record_index : BIT_COUNT_16_TYPE := 1; Next_byte : BIT_COUNT_8_TYPE; Null_byte : BIT_COUNT_8_TYPE := 16#00#; Null_line_indicator : BIT_COUNT_8_TYPE := 16#00#; Number_of_bytes_in_buffer : BIT_COUNT_16_TYPE; Number_of_bytes_in_line : BIT_COUNT_16_TYPE; Number_of_header_blocks : BIT_COUNT_16_TYPE := 0; Number_of_trailing_carriage_returns : BIT_COUNT_16_TYPE := 0; Output_file : Text_io.file_type; Ready_to_move_to_next_line : BOOLEAN := TRUE; Starting_index : BIT_COUNT_16_TYPE; FUNCTION Current_data_is_eof_marker ( Data_byte : IN BIT_COUNT_8_TYPE ) RETURN BOOLEAN IS BEGIN RETURN data_byte = eof_indicator ; END Current_data_is_eof_marker ; FUNCTION Current_data_is_eor_marker ( Data_byte : IN BIT_COUNT_8_TYPE ) RETURN BOOLEAN IS BEGIN RETURN data_byte = eor_indicator ; END Current_data_is_eor_marker ; PROCEDURE Find_out_if_user_wants_data_echoed_to_screen_during_transfer IS Reply : STRING (1..3); --&MT Reply_length : BIT_COUNT_16_TYPE; Reply_length : BIT_COUNT_32_TYPE; BEGIN Ftp_terminal_driver.output_message (" Echo data (Y/N)? "); TEXT_IO.GET_LINE ( Reply, Reply_length ); IF Reply ( Reply'FIRST ) = 'Y' OR ELSE Reply ( Reply'FIRST ) = 'y' THEN Data_echoing_is_desired := TRUE; ELSE Data_echoing_is_desired := FALSE; END IF; Ftp_terminal_driver.new_line; END Find_out_if_user_wants_data_echoed_to_screen_during_transfer; --MT PROCEDURE Null_fill_input_block IS --MT BEGIN --MT -- MY_DEBUG_IO.PUT_LINE (" ~~ Null filling input block ~~"); --MT FOR Index IN 1..Input_Block_Size LOOP --MT Input_block ( Index ) := 16#00#; --MT END LOOP; --MT -- MY_DEBUG_IO.PUT_LINE (" ~~ Input block has been null filled ~~"); --MT EXCEPTION --MT WHEN OTHERS => RAISE; --MT END Null_fill_input_block ; --MT PROCEDURE Null_fill_input_record IS --MT BEGIN --MT FOR Index IN 1..Input_Record_Size LOOP --MT Input_record ( Index ) := Null_byte; --MT END LOOP; --MT EXCEPTION --MT WHEN OTHERS => RAISE; --MT END Null_fill_input_record ; --MT PROCEDURE Skip_header_blocks IS --MT Blocks_skipped : BIT_COUNT_16_TYPE := 0; --MT BEGIN --MT WHILE Blocks_skipped < Number_of_header_blocks LOOP --MT Read_block_from_input_file; --MT Blocks_skipped := Blocks_skipped + 1; --MT END LOOP; --MT END Skip_header_blocks; PROCEDURE Open_input_file ( File_name : IN STRING ) IS BEGIN My_debug_io.put_line (" ~~ Opening file ~~"); my_debug_io.put("open_input_file.file_name =") ; my_debug_io.put_line(file_name) ; TEXT_io.OPEN ( Input_file, TEXT_io.in_file, File_name ); --Skip_header_blocks; EXCEPTION WHEN OTHERS => RAISE Error_opening_file; END Open_input_file; PROCEDURE Create_output_file ( File_name : IN STRING ) IS BEGIN IF Text_io.is_open ( Output_file ) THEN RAISE Error_creating_file; END IF; Text_io.create ( Output_file, Text_io.out_file, File_name ); EXCEPTION WHEN OTHERS => RAISE Error_creating_file; END Create_output_file; PROCEDURE Close_output_file IS BEGIN IF Text_io.is_open ( Output_file ) THEN Text_io.close ( Output_file ); END IF; EXCEPTION WHEN OTHERS => RAISE Error_closing_file; END Close_output_file; PROCEDURE Close_input_file IS BEGIN TEXT_io.close ( Input_file ); EXCEPTION WHEN OTHERS => RAISE Error_closing_file; END Close_input_file; PROCEDURE Write_record_to_output_file IS Temp_byte : BIT_COUNT_8_TYPE ; Ch : Character; BEGIN FOR Index IN record_spec'RANGE LOOP Temp_byte := Output_record( Index ); if Data_echoing_is_desired AND temp_byte /= eof_indicator THEN My_utilities.output_byte_to_screen ( Temp_byte ); END IF; if temp_byte = eor_indicator then text_io.new_line(output_file) ; IF data_echoing_is_desired THEN text_io.new_line ; END IF ; Exit; elsif temp_byte = eof_indicator THEN EXIT; else Ch := character'val(integer(temp_byte)); Text_io.put( Output_file, Ch); end if; END LOOP; EXCEPTION WHEN OTHERS => RAISE File_write_error; END Write_record_to_output_file; PROCEDURE Read_record_from_input_file IS CH : CHARACTER ; BEGIN end_of_record := -1 ; IF TEXT_IO.END_OF_FILE(INPUT_FILE) THEN --dMT my_debug_io.put_line("end of FILE detected") ; end_of_record := end_of_record + 1 ; INPUT_RECORD(end_of_record) := Eof_indicator ; RAISE End_of_file; END IF ; FOR INDEX IN record_spec'RANGE LOOP TEXT_IO.GET ( Input_file, CH); NEXT_BYTE := BIT_COUNT_8_TYPE(CHARACTER'POS(CH)) ; --dMT my_debug_io.put("read_RECORD_from_input_file.next_byte=") ; --dMT my_utilities.output_byte_to_screen(next_byte) ; --dMT my_debug_io.put_line(" ") ; end_of_record := end_of_record + 1 ; Input_record ( end_of_record ) := Next_byte; IF Data_echoing_is_desired THEN My_utilities.output_byte_to_screen ( Next_byte ); END IF; IF TEXT_IO.END_OF_LINE(INPUT_FILE) THEN --dMT my_debug_io.put_line("end of record detected") ; end_of_record := end_of_record + 1 ; INPUT_RECORD(end_of_record) := Eor_indicator ; EXIT; END IF ; END LOOP; EXCEPTION WHEN OTHERS => RAISE File_read_error; END Read_record_from_input_file; PROCEDURE Read_block_from_input_file IS CH : CHARACTER ; BEGIN end_of_block := 0 ; IF TEXT_IO.END_OF_FILE(INPUT_FILE) THEN --dMT MY_DEBUG_IO.PUT_LINE("END OF FILE RAISED") ; end_of_block := end_of_block + 1 ; input_block(end_of_block) := eof_indicator ; RAISE End_of_file; END IF ; for Index in BLOCK_SPEC'RANGE LOOP TEXT_io.GET ( Input_file, CH ); NEXT_BYTE := BIT_COUNT_8_TYPE(CHARACTER'POS(CH)) ; --dMT my_debug_io.put("read_block_from_input_file.next_byte=") ; --dMT my_utilities.output_byte_to_screen(next_byte) ; --dMT my_debug_io.put_line(" ") ; end_of_block := end_of_block + 1 ; Input_block ( end_of_block ) := Next_byte; IF TEXT_IO.END_OF_LINE(INPUT_FILE) THEN --dMT my_debug_io.put_line("end of record detected") ; end_of_block := end_of_block + 1 ; input_block(end_of_block) := eor_indicator ; END IF; IF TEXT_IO.END_OF_FILE(INPUT_FILE) THEN EXIT ; END IF ; END LOOP; END Read_block_from_input_file; PROCEDURE Write_block_to_output_file is Temp_byte : BIT_COUNT_8_TYPE ; Ch : Character; BEGIN FOR Index IN start_of_block..end_of_block LOOP Temp_byte := Output_block( Index ); IF temp_byte = eof_indicator THEN EXIT; ELSIF temp_byte = eor_indicator THEN text_io.new_line(output_file) ; IF data_echoing_is_desired THEN My_utilities.output_byte_to_screen ( Temp_byte ); END IF ; ELSE Ch := character'val(integer(Temp_byte)); Text_io.put ( Output_file, Ch); IF Data_echoing_is_desired THEN My_utilities.output_byte_to_screen ( Temp_byte ); END IF; END IF ; END LOOP; EXCEPTION WHEN OTHERS => RAISE File_write_error; END Write_block_to_output_file; BEGIN NULL; END Ftp_low_level_io; --:::::::::::::: --ftpfileio_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01078-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPFILEIO_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPFILEIO AUTHOR : MARK VOLPE -- 5/17/85 9:17 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 1:10 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/30/85 3:12 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT WITH Ftp_low_level_io; USE Ftp_low_level_io; WITH My_utilities, My_debug_io, Vt100, SYSTEM, Ftp_tcp; USE My_utilities, Ftp_tcp; PACKAGE Ftp_file_io IS Buffer_access_error : EXCEPTION; Close_request_failed : EXCEPTION; Create_request_failed : EXCEPTION; Fatal_error : EXCEPTION; File_Receive_error : EXCEPTION; File_send_error : EXCEPTION; Open_request_failed : EXCEPTION; Tcp_request_failed : EXCEPTION; PROCEDURE Find_out_if_user_wants_data_echoed_to_screen; PROCEDURE Open_input_file ( File_name : IN STRING ); ---------------------------------------------------------------------- -- -- This procedure opens the specified file as an input file. -- -- Exceptions: Open_request_failed, Error_closing_file. ---------------------------------------------------------------------- PROCEDURE Open_output_file ( File_name : IN STRING ); ---------------------------------------------------------------------- -- -- This procedure creates the specified file as an output file. -- -- Exceptions: Create_request_failed. ---------------------------------------------------------------------- PROCEDURE Close_input_file; ---------------------------------------------------------------------- -- -- This procedure closes the input file. -- -- Exceptions: Close_request_failed. ---------------------------------------------------------------------- PROCEDURE Close_output_file; ---------------------------------------------------------------------- -- -- This procedure closes the output file. -- -- Exceptions: Close_request_failed. ---------------------------------------------------------------------- PROCEDURE Send_file_as_records ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ); ---------------------------------------------------------------------- -- -- This procedure reads the current input file and loads the data -- into tcp buffers where they are transmitted. -- -- Exceptions: File_send_error, tcp_request_failed. ---------------------------------------------------------------------- PROCEDURE Send_file_as_stream ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ); ---------------------------------------------------------------------- -- -- This procedure reads the current input file and loads the data -- into tcp buffers where they are transmitted. -- -- Exceptions: File_send_error, tcp_request_failed. ---------------------------------------------------------------------- PROCEDURE Receive_file_as_records ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ); ---------------------------------------------------------------------- -- -- This procedure reads tcp buffers and stores them into the -- current output file. -- -- Exceptions: Tcp_request_failed, File_receive_error. ---------------------------------------------------------------------- PROCEDURE Receive_file_as_stream ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ); ---------------------------------------------------------------------- -- -- This procedure reads the current input file and loads the data -- into tcp buffers where they are transmitted. -- -- Exceptions: Tcp_request_failed, File_receive_error. ---------------------------------------------------------------------- END FTP_FILE_IO ; --:::::::::::::: --ftpfileio.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01079-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPFILEIO.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPFILEIO AUTHOR : MARK VOLPE -- 5/30/85 3:20 PM : REVISED FOR USE WITH THE DEC COMPILER -- ; OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/22/85 3:52 PM : ENABLE DEBUG OUTPUTS -- 7/23/85 3:09 PM : use global data for file io -- 7:10 PM : alter send_file_as_stream,load_record_from_tcp_buffer -- 10:10 PM : in send_as_records load last record before push -- 7/24/85 1:03 AM : don't do push in send_file_as_records exc handler -- 3:08 AM : remove some debug -- 4:44 AM : ad delay statements after sending files to allow -- ; tcp to get last data packet over WITH TEXT_IO; PACKAGE BODY Ftp_file_io IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.BYTE; SUBTYPE BIT_COUNT_8_TYPE IS SYSTEM.UNSIGNED_BYTE; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PACKAGE SYSTEM_BYTE IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_8_TYPE); Null_byte : CONSTANT BIT_COUNT_8_TYPE := 16#00#; Line_feed : CONSTANT BIT_COUNT_8_TYPE := 16#0A#; Carriage_return : CONSTANT BIT_COUNT_8_TYPE := 16#0D#; Block_index : Block_index_spec := Start_of_block; --&MT Record_index : BIT_COUNT_16_TYPE := Start_of_record; Record_index : BIT_COUNT_32_TYPE := Start_of_record; Eof_found : EXCEPTION; Dummy_1 : EXCEPTION; Dummy_2 : EXCEPTION; Dummy_3 : EXCEPTION; Dummy_4 : EXCEPTION; Dummy_5 : EXCEPTION; Dummy_6 : EXCEPTION; Dummy_7 : EXCEPTION; PROCEDURE Find_out_if_user_wants_data_echoed_to_screen IS BEGIN Find_out_if_user_wants_data_echoed_to_screen_during_transfer; END Find_out_if_user_wants_data_echoed_to_screen; PROCEDURE Open_input_file ( File_name : IN STRING ) IS BEGIN MY_DEBUG_IO.PUT_LINE (" Opening file "); Ftp_low_level_io.Open_input_file ( File_name ); EXCEPTION WHEN OTHERS => RAISE Open_request_failed; END Open_input_file; PROCEDURE Open_output_file ( File_name : IN STRING ) IS BEGIN My_debug_io.put_line (" ~~ Opening output file ~~"); Ftp_low_level_io.Create_output_file ( File_name ); EXCEPTION WHEN OTHERS => RAISE Create_request_failed; -- local error END Open_output_file ; PROCEDURE Close_input_file IS BEGIN MY_DEBUG_IO.PUT_LINE (" ~~ Closing input file ~~"); Ftp_low_level_io.Close_input_file; EXCEPTION WHEN OTHERS => RAISE Close_request_failed; -- Local error END Close_input_file; PROCEDURE Close_output_file IS BEGIN MY_DEBUG_IO.PUT_LINE (" ~~ Closing output file ~~"); Ftp_low_level_io.Close_output_file; EXCEPTION WHEN OTHERS => RAISE Close_request_failed; -- Local error END Close_output_file; PROCEDURE Load_end_of_record_indicator_into_tcp_buffer ( Tcp_identifier : IN OUT Tcp_identifier_spec ) IS BEGIN --MT MY_DEBUG_IO.PUT_LINE (" Loading <EOR> "); --MT Load_byte_into_tcp_buffer(Tcp_identifier, Carraige_return); --MT Load_byte_into_tcp_buffer(Tcp_identifier, Line_feed); --MT Load_byte_into_tcp_buffer(Tcp_identifier, End_of_record_delimeter); NULL ; EXCEPTION WHEN OTHERS => RAISE Tcp_request_failed; -- local err END Load_end_of_record_indicator_into_tcp_buffer; PROCEDURE Load_end_of_file_indicator_into_tcp_buffer ( Tcp_identifier : IN OUT Tcp_identifier_spec ) IS BEGIN MY_DEBUG_IO.PUT_LINE (" ~~ Loading <EOF> ~~"); Load_byte_into_tcp_buffer(Tcp_identifier, BIT_COUNT_8_TYPE'( 16#F2# )); EXCEPTION WHEN OTHERS => RAISE Tcp_request_failed; -- local err END Load_end_of_file_indicator_into_tcp_buffer; PROCEDURE Load_next_record_into_tcp_buffer ( Tcp_identifier : IN OUT Tcp_identifier_spec ) IS BEGIN MY_DEBUG_IO.PUT_LINE (" Loading next record into tcp buffer "); FOR Local_record_index IN Start_of_record..End_of_record loop FTP_TCP.Load_byte_into_tcp_buffer ( Tcp_identifier, Input_record( Local_record_index )); IF Current_data_is_eor_marker(Input_record(Local_record_index)) THEN EXIT; END IF; END LOOP; --MT Load_end_of_record_indicator_into_tcp_buffer( Tcp_identifier ); MY_DEBUG_IO.PUT_LINE (" Fileio requested push "); Push_tcp_buffer ( Tcp_identifier ); EXCEPTION WHEN OTHERS => RAISE Tcp_request_failed; END Load_next_record_into_tcp_buffer; PROCEDURE Send_file_as_records ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ) IS BEGIN MY_DEBUG_IO.put_line (" Sending file as records "); LOOP Ftp_low_level_io.Read_record_from_input_file; -- Loads input_record Load_next_record_into_tcp_buffer( Tcp_identifier ); END LOOP; EXCEPTION WHEN FTP_TCP.Tcp_request_failed => MY_DEBUG_IO.PUT_LINE (" ~~ Tcp request failed ~~"); RAISE Tcp_request_failed; WHEN Ftp_low_level_io.End_of_file | Ftp_low_level_io.file_read_error => MY_DEBUG_IO.PUT_LINE (" ~~ End of file found ~~"); Load_next_record_into_tcp_buffer( Tcp_identifier ); DELAY(DURATION(6)) ; -- allow time for last packet to arrive WHEN OTHERS => My_debug_io.put_line(" Unknown error in send file as records "); RAISE File_send_error; END Send_file_as_records; PROCEDURE Load_next_block_into_tcp_buffer ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ) IS BEGIN MY_DEBUG_IO.PUT_LINE (" Load next block into tcp buffer "); FOR Local_index IN Start_of_block..End_of_block loop Load_byte_into_tcp_buffer ( Tcp_identifier, Input_block( Local_index )); IF Current_data_is_eof_marker( Input_block( Local_index )) THEN EXIT; END IF; END LOOP; EXCEPTION WHEN OTHERS => RAISE Tcp_request_failed; END Load_next_block_into_tcp_buffer; PROCEDURE Send_file_as_stream ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ) IS BEGIN MY_DEBUG_IO.PUT_LINE (" Send file as stream "); LOOP Read_block_from_input_file; Load_next_block_into_tcp_buffer( Tcp_identifier ); END LOOP; -- Can only exit through an exception handler EXCEPTION WHEN Ftp_low_level_io.End_of_file | Ftp_low_level_io.File_read_error => MY_DEBUG_IO.PUT_LINE (" ~~ End of file found ~~"); Load_next_block_into_tcp_buffer( Tcp_identifier ); --MT Load_end_of_file_indicator_into_tcp_buffer(Tcp_identifier ); Push_tcp_buffer ( Tcp_identifier ); DELAY(DURATION(6)) ; -- allow last packet to arrive WHEN Tcp_request_failed => RAISE Tcp_request_failed; WHEN OTHERS => RAISE File_send_error; END Send_file_as_stream; --&MT PROCEDURE Null_fill_remainder_of_output_block IS --&MT BEGIN --&MT FOR Local_block_index IN Block_index..End_of_block LOOP --&MT Output_block ( Local_block_index ) := Null_byte; --&MT END LOOP; --&MT EXCEPTION --&MT WHEN OTHERS => RAISE; --&MT End Null_fill_remainder_of_output_block; PROCEDURE Load_next_block_from_tcp_buffer (Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec) IS Temp_byte : BIT_COUNT_8_TYPE; BEGIN end_of_block := 0 ; --dMT MY_DEBUG_IO.put_line (" Load next block from tcp buffer "); FOR Local_block_index IN block_spec'range LOOP Get_byte_from_tcp_buffer(Tcp_identifier, Temp_byte); end_of_block := end_of_block + 1 ; Output_block ( Local_block_index ) := Temp_byte; Block_index := Local_block_index; -- Save for exception handlers IF Current_data_is_eof_marker ( Temp_byte ) THEN RAISE Eof_found; END IF; END LOOP; EXCEPTION WHEN Eof_found => RAISE Eof_found; WHEN No_more_tcp_data => RAISE ; -- Blk index pnts to last byte of data WHEN OTHERS => RAISE Tcp_request_failed; END Load_next_block_from_tcp_buffer; PROCEDURE Receive_file_as_stream ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ) IS BEGIN MY_DEBUG_IO.put_line (" ~~ Receive file as stream ~~"); LOOP Load_next_block_from_tcp_buffer( Tcp_identifier ); Write_block_to_output_file; END LOOP; EXCEPTION WHEN Eof_found => Write_block_to_output_file; Wait_for_tcp_connection_to_close ( Tcp_identifier ); WHEN No_more_tcp_data | Tcp_connection_closed => NULL ; --MT Null_fill_remainder_of_output_block; -- Write_block_to_output_file; WHEN Tcp_request_failed => RAISE Tcp_request_failed; WHEN OTHERS => RAISE File_receive_error; END Receive_file_as_stream; PROCEDURE Load_record_from_tcp_buffer ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ) IS Temp_byte : BIT_COUNT_8_TYPE; BEGIN --dMT my_debug_io.put_line (" Load record from tcp buffer "); --dMT my_debug_io.put (" Start of record = "); --dMT my_debug_io.put_Line (bit_count_16_type(Start_of_record)); --dMT my_debug_io.put (" End of record = "); --dMT my_debug_io.put_Line ( bit_count_16_type(end_of_record)); FOR Local_record_index IN record_spec'range LOOP Get_byte_from_tcp_buffer ( Tcp_identifier, Temp_byte ); Output_record( Local_record_index ) := Temp_byte; Record_index := Local_record_index; --dMT IF temp_byte IN 0..127 THEN --dMT My_debug_io.put (" Byte = "); --dMT My_utilities.output_byte_to_screen ( Temp_byte ); --dMT END IF ; --dMT TEXT_IO.new_line; --dMT my_debug_io.put (" Local_record_index = "); --dMT my_debug_io.put (BIT_COUNT_16_TYPE(Local_record_index)); IF Current_data_is_eor_marker( Temp_byte ) THEN --dMT My_debug_io.put_line(" <EOR> detected; Done with buffer "); EXIT; ELSIF Current_data_is_eof_marker( Temp_byte ) THEN --dMT My_debug_io.put_line(" <EOF> detected; Done with buffer "); RAISE Eof_found; END IF; END LOOP; -- Record_index points to last byte in output_record EXCEPTION WHEN Eof_found => MY_DEBUG_IO.PUT_LINE (" <EOF> exception propagating up "); RAISE Eof_found; WHEN No_more_tcp_data => MY_DEBUG_IO.PUT_LINE (" Load_record_from_tcp_buffer failed"); MY_DEBUG_IO.PUT_LINE (" Raising No_more_tcp_data"); RAISE No_more_tcp_data; WHEN Tcp_request_failed => MY_DEBUG_IO.PUT_LINE (" Load_record_from_tcp_buffer failed"); MY_DEBUG_IO.PUT_LINE (" Raising Tcp_request_failed "); RAISE Tcp_request_failed; WHEN OTHERS => MY_DEBUG_IO.PUT_LINE (" Load_record_from_tcp_buffer failed"); MY_DEBUG_IO.PUT_LINE (" Raising File receive error"); RAISE File_receive_error; END Load_record_from_tcp_buffer; PROCEDURE Receive_file_as_records ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ) IS BEGIN My_debug_io.put_line (" ~~ Receive file as records ~~"); LOOP Load_record_from_tcp_buffer( Tcp_identifier ); Write_record_to_output_file; END LOOP; EXCEPTION WHEN Eof_found => Write_record_to_output_file; Wait_for_tcp_connection_to_close ( Tcp_identifier ); WHEN No_more_tcp_data | Tcp_connection_closed => My_debug_io.put_line (" Receive file as records failed"); My_debug_io.put_line (" No more tcp data; connection closed "); WHEN tcp_request_failed => My_debug_io.put_line (" Receive file as records failed"); My_debug_io.put_line (" Raising tcp_request failed"); RAISE tcp_request_failed ; WHEN OTHERS => My_debug_io.put_line (" Receive file as records failed"); My_debug_io.put_line (" Raise file receive error "); RAISE File_receive_error; END Receive_file_as_records; END Ftp_file_io ; --:::::::::::::: --ftpsite_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01091-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSITE_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSITE AUTHOR : MARK VOLPE -- 5/17/85 10:47 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 2:35 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 8 :41 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH Ftp_types, Ftp_terminal_driver; PACKAGE Site_details IS FUNCTION Type_supported ( Argument : IN FTP_TYPES.ARGUMENT_LIST ) RETURN BOOLEAN ; ---------------------------------------------------------------------- -- -- This function indicates if the specified type is implemented -- ---------------------------------------------------------------------- FUNCTION Print_type_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN ; ---------------------------------------------------------------------- -- -- This function indicates if the specified carriage control -- is implemented -- ---------------------------------------------------------------------- FUNCTION Mode_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN ; ---------------------------------------------------------------------- -- -- This function indicates if the specified mode is implemented -- ---------------------------------------------------------------------- FUNCTION Structure_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN ; ---------------------------------------------------------------------- -- -- This function indicates if the specified structure is implemented -- ---------------------------------------------------------------------- FUNCTION Specified_host_is_this_host ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN ; ---------------------------------------------------------------------- -- -- This function indicates if the specified host is this host -- ---------------------------------------------------------------------- END Site_details; --:::::::::::::: --ftpsite.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01092-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSITE.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSITE AUTHOR : MARK VOLPE -- 5/17/85 10:47 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 2:35 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 8:45 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING STATEMENT WAS ADDED TO ALLOW PACKAGE FTPSITE ACCES TO --&MT TEXT_IO : WITH TEXT_IO; PACKAGE BODY Site_details IS --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); Ascii_type_supported : CONSTANT BOOLEAN := TRUE; Ebcdic_type_supported : CONSTANT BOOLEAN := FALSE; Image_type_supported : CONSTANT BOOLEAN := FALSE; Local_byte_type_supported : CONSTANT BOOLEAN := FALSE; Non_print_supported : CONSTANT BOOLEAN := TRUE; Telnet_supported : CONSTANT BOOLEAN := FALSE; Asa_supported : CONSTANT BOOLEAN := FALSE; File_structure_supported : CONSTANT BOOLEAN := TRUE; Record_structure_supported : CONSTANT BOOLEAN := TRUE; Page_structure_supported : CONSTANT BOOLEAN := FALSE; Stream_mode_supported : CONSTANT BOOLEAN := TRUE; Block_mode_supported : CONSTANT BOOLEAN := FALSE; Compressed_mode_supported : CONSTANT BOOLEAN := FALSE; Host_id : CONSTANT STRING(1..8) := "1,2,3,4,"; FUNCTION Specified_host_is_this_host ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN IS Argument_index : BIT_COUNT_16_TYPE := Argument'FIRST; BEGIN FOR Index IN Host_id'RANGE LOOP IF Host_id( Index ) /= Argument( Argument_index ) THEN RETURN FALSE; ELSE Argument_index := Argument_index + 1; END IF; END LOOP; RETURN TRUE; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Specified_Host_Is_This_Host"); RAISE; END Specified_host_is_this_host; FUNCTION Type_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN IS Return_status : BOOLEAN := FALSE; BEGIN IF Argument( Argument'FIRST ) = 'A' THEN Return_status := Ascii_type_supported; ELSIF Argument( Argument'first ) = 'E' THEN Return_status := Ebcdic_type_supported; ELSIF Argument( Argument'first ) = 'I' THEN Return_status := Image_type_supported; ELSIF Argument( Argument'first ) = 'L' THEN Return_status := Local_byte_type_supported; ELSE Return_status := FALSE; END IF; RETURN Return_status; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Type_supported"); RAISE; END Type_supported; FUNCTION Print_type_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN IS Return_status : BOOLEAN := FALSE; BEGIN IF Argument( Argument'first ) = 'N' THEN Return_status := Non_print_supported; ELSIF Argument( Argument'first ) = 'T' THEN Return_status := Telnet_supported; ELSIF Argument( Argument'first ) = 'C' THEN Return_status := Asa_supported; ELSE Return_status := FALSE; END IF; RETURN Return_status; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in print_type_supported"); RAISE; END Print_type_supported; FUNCTION Structure_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN IS Return_status : BOOLEAN := FALSE; BEGIN IF Argument( Argument'first ) = 'F' THEN Return_status := File_structure_supported; ELSIF Argument( Argument'first ) = 'P' THEN Return_status := Page_structure_supported; ELSIF Argument( Argument'first ) = 'R' THEN Return_status := Record_structure_supported; ELSE Return_status := FALSE; END IF; RETURN Return_status; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Structure_supported"); RAISE; END Structure_supported; FUNCTION Mode_supported ( Argument : IN Ftp_types.argument_list ) RETURN BOOLEAN IS Return_status : BOOLEAN := FALSE; BEGIN IF Argument( Argument'first ) = 'S' THEN Return_status := Stream_mode_supported; ELSIF Argument( Argument'first ) = 'B' THEN Return_status := Block_mode_supported; ELSIF Argument( Argument'first ) = 'C' THEN Return_status := Compressed_mode_supported; ELSE Return_status := FALSE; END IF; RETURN Return_status; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Mode_supported"); RAISE; END Mode_supported; BEGIN NULL; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Site_details"); RAISE; END Site_details; --:::::::::::::: --ftprpldat_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01086-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRPLDAT_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPRPLDAT AUTHOR : MARK VOLPE -- 5/17/85 11:10 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 3:02 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 8:55 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io, Ftp_types, Reply_types, Command_types; --&MT THE FOLLOWING LINE WAS ADDED TO IMPROVE VISIBILITY OF FTP_TYPES TO --&MT FTPRPLDAT. USE Ftp_types; PACKAGE Ftp_reply_data IS ---------------------------------------------------------------------- -- -- This package contains the procedures necessary to find the -- appropriate reply message for a given reply code -- ---------------------------------------------------------------------- PROCEDURE Get_reply_message_for_this_reply ( Reply : IN Reply_types.telnet_reply_code_spec; Message : OUT Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure gets the message for a given reply -- ---------------------------------------------------------------------- PRIVATE SUBTYPE Reply_array_element IS Ftp_types.argument_list; Reply_array : ARRAY (1..42) OF Reply_array_element; END Ftp_reply_data; --:::::::::::::: --ftprpldat.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01087-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRPLDAT.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPRPLDAT AUTHOR : MARK VOLPE -- 5/17/85 11:15 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/30/85 3:02 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 8:59 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE WAS ADDED TO PROVIDE PACKAGE FTPRPLDAT ACCESS TO --&MT TEXT_IO : WITH TEXT_IO; PACKAGE BODY Ftp_reply_data IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PROCEDURE Get_reply_message_for_this_reply ( Reply : IN Reply_types.telnet_reply_code_spec; Message : OUT Ftp_types.argument_list ) IS Message_error : EXCEPTION; Reply_found : BOOLEAN := TRUE; Temp_message : Ftp_types.argument_list; BEGIN Temp_message := Ftp_types.null_argument; FOR Index IN Reply_array'range LOOP FOR Offset IN 1..3 LOOP IF Reply_array( Index )( bit_count_16_type(Offset) ) = Reply( bit_count_16_type(Offset)) THEN NULL; ELSE Reply_found := FALSE; END IF; END LOOP; IF Reply_found THEN Temp_message := Reply_array( Index ); EXIT; ELSE Reply_found := TRUE; END IF; END LOOP; IF Temp_message = Ftp_types.null_argument THEN RAISE Message_error; END IF; Message := Temp_message; EXCEPTION WHEN Message_error => my_debug_io.PUT_LINE(" Illegal reply code passed to " & " Get_Reply_Message_For_This_Reply"); RAISE; WHEN OTHERS => my_debug_io.PUT_LINE (" Unknown error in Get_Reply_Message_For_This_Reply"); RAISE; END Get_reply_message_for_this_reply; PROCEDURE Assign ( Reply : OUT Ftp_types.argument_list; Message_text : IN STRING ) IS Reply_index : BIT_COUNT_16_TYPE := Reply'first; Null_start : BIT_COUNT_16_TYPE := Reply'first; BEGIN FOR Index IN Message_text'range LOOP Reply( Reply_index ) := Ftp_types.argument_list_unit'( Message_text(index)); Reply_index := Reply_index + 1; Null_start := Null_start + 1; END LOOP; FOR Index IN Null_start..reply'last LOOP Reply( Index ) := Ftp_types.argument_list_unit'( ASCII.NUL ); END LOOP; EXCEPTION WHEN OTHERS => my_debug_io.PUT_LINE (" Unknown error in assign"); RAISE; END ASSIGN; BEGIN ASSIGN(REPLY_ARRAY(1), "110 Restart marker reply"); ASSIGN(REPLY_ARRAY(2), "119 Terminal not avaliable, will try mailbox" ); ASSIGN(REPLY_ARRAY(3), "120 Service ready in nnn minutes"); ASSIGN(REPLY_ARRAY(4), "125 Data connection already open; transfer starting"); ASSIGN(REPLY_ARRAY(5), "150 File status ok, about to open data connection"); ASSIGN(REPLY_ARRAY(6), "151 User not local; will try formward"); ASSIGN(REPLY_ARRAY(7), "152 User unknown; Mail will be forwarded by operator"); ASSIGN(REPLY_ARRAY(8), "200 Command okay"); ASSIGN(REPLY_ARRAY(9), "202 Command not implemented, superflous at this site"); ASSIGN(REPLY_ARRAY(10), "211 System status, or system help reply"); ASSIGN(REPLY_ARRAY(11), "212 Directory status"); ASSIGN(REPLY_ARRAY(12), "213 File status"); ASSIGN(REPLY_ARRAY(13), "214 Help message"); ASSIGN(REPLY_ARRAY(14), "215 <scheme> is the preferred scheme"); ASSIGN(REPLY_ARRAY(15), "220 Service ready for new user"); ASSIGN(REPLY_ARRAY(16), "221 Service closing telnet connection"); ASSIGN(REPLY_ARRAY(17), "225 Data connection open, no transfer in progress"); ASSIGN(REPLY_ARRAY(18), "226 Closing data connection; requested file action successful"); ASSIGN(REPLY_ARRAY(19), "227 Entering passive mode"); ASSIGN(REPLY_ARRAY(20), "230 User logged in, proceed"); ASSIGN(REPLY_ARRAY(21), "250 Requested file action ok, completed"); ASSIGN(REPLY_ARRAY(22), "331 User name ok, need password"); ASSIGN(REPLY_ARRAY(23), "332 Need account for login"); ASSIGN(REPLY_ARRAY(24), "350 Requested file action pending further information"); ASSIGN(REPLY_ARRAY(25), "354 Start mail input; end with <CR><LF>.<CR><LF>"); ASSIGN(REPLY_ARRAY(26), "421 Service not avaliable, closing TELNET connection"); ASSIGN(REPLY_ARRAY(27), "425 Can't open data connection"); ASSIGN(REPLY_ARRAY(28), "426 Connection closed, transfer aborted"); ASSIGN(REPLY_ARRAY(29), "450 Requested file action not taken: file unavailable"); ASSIGN(REPLY_ARRAY(30), "451 Requested action aborted, local error in processing"); ASSIGN(REPLY_ARRAY(31), "452 Requested action not taken: insuffecient storage space in system"); ASSIGN(REPLY_ARRAY(32), "500 Syntax error, command unrecognized"); ASSIGN(REPLY_ARRAY(33), "501 Syntax error in parameters or arguments"); ASSIGN(REPLY_ARRAY(34), "502 Command not implemented"); ASSIGN(REPLY_ARRAY(35), "503 Bad sequence of commands"); ASSIGN(REPLY_ARRAY(36), "504 Command not implemented for that parameter"); ASSIGN(REPLY_ARRAY(37), "530 Not logged in"); ASSIGN(REPLY_ARRAY(38), "532 Need account for storing files"); ASSIGN(REPLY_ARRAY(39), "550 Requested action not taken: file unavailable"); ASSIGN(REPLY_ARRAY(40), "551 Requested action aborted: page type unknown"); ASSIGN(REPLY_ARRAY(41), "552 Requested file action aborted: exceeded storage allocation"); ASSIGN(REPLY_ARRAY(42), "553 Requested file action not taken: file name not allowed"); EXCEPTION WHEN OTHERS => my_debug_io.PUT_LINE ("Illegal reply code passed to Ftp_Reply_Data"); RAISE; END FTP_REPLY_DATA; --:::::::::::::: --ftprplutl_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01088-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRPLUTL_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPRPLUTL AUTHOR : MARK VOLPE -- 5/17/85 2:27 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 8:49 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 9:19 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH Ftp_types; WITH Reply_types; USE Reply_types; WITH Command_types; WITH Ftp_reply_data; WITH Ftp_telnet; WITH Ftp_terminal_driver; WITH My_debug_io; --&MT THE FOLLOWING LINE WAS ADDED TO PROVIDE FTPRPLUTL WITH ACCESS TO --&MT TEXT_IO: WITH TEXT_IO; PACKAGE Reply_utilities IS ---------------------------------------------------------------------- -- -- This package contains utilities for processing replys -- ---------------------------------------------------------------------- PROCEDURE Get_reply_from_telnet( Reply : OUT reply_code_spec); ---------------------------------------------------------------------- -- -- This procedure accepts a 3 digit reply code and message -- text from a server pi. The text is output to the nvt -- printer. The reply code is used for processing. -- ---------------------------------------------------------------------- PROCEDURE Add_text_to_reply ( Input_reply_code : IN telnet_reply_code_spec ; Message : OUT Ftp_types.argument_list ) ; ---------------------------------------------------------------------- -- -- This procedure accepts a reply code and adds the -- appropriate message text. -- ---------------------------------------------------------------------- PROCEDURE Indicate_multiline_reply ( Reply_message : IN OUT Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure indicates that the reply message is part of a -- multiline reply -- ---------------------------------------------------------------------- END Reply_utilities; --:::::::::::::: --ftprplutl.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01089-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPRPLUTL.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftprplutl AUTHOR : MARK VOLPE -- 5/17/85 2:55 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 8:49 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 9:29 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY Reply_utilities IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PROCEDURE RECORD_THE_REPLY_CODE ( Telnet_reply : IN OUT Command_types.command_string_spec; REPLY : IN OUT reply_code_spec) IS ---------------------------------------------------------------------- -- -- This procedure converts the 3 digit reply that was received from -- telnet into an enumerated type. -- ---------------------------------------------------------------------- Temp_char : CHARACTER ; Temp_reply_code : valid_reply_code_character; BEGIN Temp_reply_code := Telnet_reply( Telnet_reply'FIRST); IF Temp_reply_code = Code_for_positive_preliminary_reply THEN Reply.code := Positive_preliminary_reply_code; ELSIF Temp_reply_code = Code_for_positive_completion_reply THEN Reply.code := Positive_completion_reply_code; ELSIF Temp_reply_code = Code_for_positive_intermediate_reply THEN Reply.code := Positive_intermediate_reply_code; ELSIF Temp_reply_code = Code_for_transient_negative_completion_reply THEN Reply.code := Transient_negative_completion_reply_code; ELSIF Temp_reply_code = Code_for_permanent_negative_completion_reply THEN Reply.code := Permanent_negative_completion_reply_code; ELSE Reply.code := Permanent_negative_completion_reply_code; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in Record_the_reply_code"); RAISE; END Record_the_reply_code; PROCEDURE Record_the_reply_type ( Telnet_reply : IN OUT Command_types.command_string_spec; Reply : IN OUT Reply_code_spec ) IS ---------------------------------------------------------------------- -- -- This procedure records the qualifier for the type of reply that -- was received -- ---------------------------------------------------------------------- Temp_char : CHARACTER ; Temp_reply_code : Valid_reply_code_character; BEGIN Temp_reply_code := Telnet_reply( Telnet_reply'FIRST); Temp_reply_code := Valid_reply_code_character'SUCC( Temp_reply_code ); IF Temp_reply_code = Code_for_syntax_qualifier THEN Reply.message_type := Syntax; ELSIF Temp_reply_code = Code_for_information_qualifier THEN Reply.message_type := Information; ELSIF Temp_reply_code = Code_for_connection_qualifier THEN Reply.message_type := Connections; ELSIF Temp_reply_code = Code_for_authentication_qualifier THEN Reply.message_type := Authentication; ELSIF Temp_reply_code = Code_for_unspecified_qualifier THEN Reply.message_type := Unspecified; ELSIF Temp_reply_code = Code_for_file_system_qualifier THEN Reply.message_type := File_system; ELSE Reply.message_type := Message_type_error; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in Record_the_reply_type"); RAISE; END Record_the_reply_type; PROCEDURE Record_the_three_digit_reply_code ( Telnet_reply : IN OUT Command_types.command_string_spec; Reply_digits : OUT Telnet_reply_code_spec ) IS ---------------------------------------------------------------------- -- -- This procedure saves the three digit code -- in case this is a multiline reply -- ---------------------------------------------------------------------- --&MT Telnet_index : BIT_COUNT_16_TYPE := Telnet_reply'FIRST; Telnet_index : BIT_COUNT_32_TYPE := Telnet_reply'FIRST; BEGIN FOR Index IN Reply_digits'RANGE LOOP Reply_digits ( Index ) := Valid_reply_code_character'( Telnet_reply( Telnet_index )); Telnet_index := Telnet_index + 1; END LOOP; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in Record_the_three_digit_reply_code"); RAISE; END Record_the_three_digit_reply_code; FUNCTION The_end_of_the_reply ( Telnet_reply : IN Command_types.command_string_spec; REPLY_DIGITS : IN Telnet_reply_code_spec ) RETURN BOOLEAN IS --&MT Telnet_index : BIT_COUNT_16_TYPE := Telnet_reply'FIRST; Telnet_index : BIT_COUNT_32_TYPE := Telnet_reply'FIRST; Return_status : BOOLEAN := TRUE; BEGIN FOR Index IN Reply_digits'RANGE LOOP IF Reply_digits( Index ) = Telnet_reply( Telnet_index ) THEN NULL; ELSE Return_status := FALSE; EXIT; END IF; Telnet_index := Telnet_index + 1; END LOOP; RETURN Return_status; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in The_end_of_the_reply"); RAISE; END The_end_of_the_reply; PROCEDURE OUTPUT_THE_REPLY_MESSAGE ( Telnet_reply : IN OUT Command_types.command_string_spec; Reply_digits : IN Telnet_reply_code_spec ) IS Telnet_status : Ftp_telnet.telnet_status_spec; BEGIN Ftp_terminal_driver.output_message_with_new_line ( Telnet_reply( 5 .. Telnet_reply'LENGTH )); -- 5 IS THE 1ST CHARACTER IN MESSAGE IF Telnet_reply(4) = '-' THEN LOOP Telnet_reply := Command_types.null_command_string; Ftp_telnet.get_data_from_telnet_buffer(Telnet_status,Telnet_reply); IF Telnet_reply ( Telnet_reply'first ) IN '0'..'9' THEN Ftp_terminal_driver.output_message_with_new_line ( Telnet_reply( 5 .. Telnet_reply'LENGTH )); -- 5 IS THE 1ST CHARACTER IN MESSAGE ELSE Ftp_terminal_driver.output_message_with_new_line(Telnet_reply); END IF; IF The_end_of_the_reply( Telnet_reply, Reply_digits ) THEN EXIT; END IF; END LOOP; ELSE NULL; -- FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE -- (TELNET_REPLY(5..TELNET_REPLY'LENGTH)); -- 5 IS THE 1ST CHARACTER IN MESSAGE END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in Output_the_reply_message"); RAISE; END Output_the_reply_message; PROCEDURE Get_reply_from_telnet ( Reply : OUT reply_code_spec) IS Telnet_reply : Command_types.command_string_spec; Telnet_status : Ftp_telnet.telnet_status_spec; Reply_digits : Telnet_reply_code_spec; Temp_reply : Reply_code_spec; BEGIN Temp_reply.message := Null_reply_message; Temp_reply.multiline_message := FALSE; My_debug_io.put_line (" Getting reply"); Ftp_telnet.get_data_from_telnet_buffer( Telnet_status, Telnet_reply ); My_debug_io.put_line (" Reply received "); Record_the_reply_code ( Telnet_reply, Temp_reply ); Record_the_reply_type ( Telnet_reply, Temp_reply ); Record_the_three_digit_reply_code( Telnet_reply, Reply_digits ); Output_the_reply_message ( Telnet_reply, Reply_digits ); Reply := Temp_reply; EXCEPTION WHEN OTHERS => -- Don't raise the exception. -- Handle it here by setting a bad return status Temp_reply.code := Reply_code_error; Temp_reply.message_type := Message_type_error; Reply := Temp_reply; Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in Get_Reply_From_Telnet"); END Get_reply_from_telnet; PROCEDURE Add_text_to_reply ( Input_reply_code : IN Telnet_reply_code_spec ; Message : OUT Ftp_types.argument_list ) IS BEGIN IF Input_reply_code( Input_reply_code'FIRST ) = Valid_reply_code_character'('0') THEN NULL; ELSE Ftp_reply_data.get_reply_message_for_this_reply ( Input_reply_code, Message ); END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line ("Unknown exception in Add_text_to_reply"); RAISE; END Add_text_to_reply; PROCEDURE Indicate_multiline_reply ( Reply_message : IN OUT Ftp_types.argument_list ) is BEGIN Reply_message(4) := Ftp_types.argument_list_unit'('-'); EXCEPTION WHEN OTHERS => RAISE; END Indicate_multiline_reply; BEGIN NULL; EXCEPTION WHEN OTHERS => FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE ("Unknown exception in Reply_utilities"); RAISE; END Reply_utilities; --:::::::::::::: --ftputl_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01118-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUTL_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUTL AUTHOR : MARK VOLPE -- 5/17/85 4:05 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 9:14 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 9:51 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io, Ftp_types, Ftp_telnet, Ftp_terminal_driver, Ftp_command_utilities, Site_details; PACKAGE Ftp_utilities IS ---------------------------------------------------------------------- -- -- This package contains FTP utility procedures -- ---------------------------------------------------------------------- -- These types, procedures and functions are used to process the -- status of an ftp command TYPE COMMAND_STATUS_SPEC IS PRIVATE; FUNCTION COMMAND_WAS_SUCCESSFUL ( COMMAND_STATUS : IN COMMAND_STATUS_SPEC ) RETURN BOOLEAN; PROCEDURE INDICATE_COMMAND_WAS_SUCCESSFUL ( COMMAND_STATUS : OUT COMMAND_STATUS_SPEC ) ; PROCEDURE INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( COMMAND_STATUS : OUT COMMAND_STATUS_SPEC ) ; -- These types are used to record parameter information for the -- current ftp system TYPE LOGIN_STATUS_SPEC IS PRIVATE; TYPE TELNET_STATUS_SPEC IS PRIVATE; TYPE FTP_PARAMETERS_SPEC IS PRIVATE; -- These types, procedures and functions are used to process the -- status of telnet_data_links and the users login status PROCEDURE INDICATE_USER_IS_LOGGED_IN ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ); PROCEDURE INDICATE_USER_IS_LOGGED_OUT ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ); FUNCTION USER_IS_LOGGED_IN ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN BOOLEAN; PROCEDURE INDICATE_TELNET_LINK_OPEN ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ); PROCEDURE INDICATE_TELNET_LINK_CLOSED ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ); FUNCTION TELNET_LINK_IS_OPEN ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN BOOLEAN; -- These procedures are used to access the -- file transfer parameters FUNCTION GET_CURRENT_PORT ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST; FUNCTION GET_CURRENT_TYPE ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST; FUNCTION GET_CURRENT_CARRIAGE_CONTROL ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST; FUNCTION GET_CURRENT_STRUCTURE ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST; FUNCTION GET_CURRENT_MODE ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST; PROCEDURE CHANGE_FILE_STRUCTURE ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ); ---------------------------------------------------------------------- -- -- This procedure changes the file structure to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE CHANGE_FILE_TYPE ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ); ---------------------------------------------------------------------- -- -- This procedure changes the file type to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE CHANGE_FILE_MODE ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ); ---------------------------------------------------------------------- -- -- This procedure changes the file mode to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE CHANGE_PORT ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ); ---------------------------------------------------------------------- -- -- This procedure changes the transmit port to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE OPEN_TELNET_LINK ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ); PROCEDURE CLOSE_TELNET_LINK ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ); PRIVATE TYPE COMMAND_STATUS_SPEC IS ( SUCCESSFUL_COMMAND, COMMAND_FAILED ); TYPE LOGIN_STATUS_SPEC IS ( LOGGED_IN, LOGGED_OUT ); TYPE TELNET_STATUS_SPEC IS ( TELNET_LINK_OPEN, TELNET_LINK_CLOSED ); TYPE FTP_PARAMETERS_SPEC IS RECORD LOCAL_LOGIN_STATUS : LOGIN_STATUS_SPEC := LOGGED_OUT; TELNET_STATUS : TELNET_STATUS_SPEC := TELNET_LINK_CLOSED; FILE_STRUCTURE : FTP_TYPES.ARGUMENT_LIST_UNIT := FTP_TYPES.DEFAULT_FILE_STRUCTURE; FILE_MODE : FTP_TYPES.ARGUMENT_LIST_UNIT := FTP_TYPES.DEFAULT_FILE_MODE; FILE_TYPE : FTP_TYPES.ARGUMENT_LIST_UNIT := FTP_TYPES.DEFAULT_FILE_TYPE; CARRIAGE_CONTROL : FTP_TYPES.ARGUMENT_LIST_UNIT := FTP_TYPES.DEFAULT_CARRIAGE_CONTROL; PORT_ID : FTP_TYPES.PORT_ID := FTP_TYPES.DEFAULT_PORT_ID; END RECORD; END FTP_UTILITIES; --:::::::::::::: --ftputl.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01119-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUTL.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUTL AUTHOR : MARK VOLPE -- 5/17/85 4:05 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 9:14 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 9:55 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE WAS ADDED TO GIVE FTPUTL.ADA ACCESS TO TEXT_IO : WITH TEXT_IO; PACKAGE BODY FTP_UTILITIES IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PROCEDURE INDICATE_USER_IS_LOGGED_IN ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ) IS BEGIN FTP_PARAMETERS.LOCAL_LOGIN_STATUS := LOGGED_IN; MY_DEBUG_IO.PUT_LINE(" ~~ User logged on to remote system ~~"); EXCEPTION WHEN OTHERS => RAISE; END INDICATE_USER_IS_LOGGED_IN; PROCEDURE INDICATE_USER_IS_LOGGED_OUT ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ) IS BEGIN FTP_PARAMETERS.LOCAL_LOGIN_STATUS := LOGGED_OUT; FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" User logged off of remote system"); RETURN; EXCEPTION WHEN OTHERS => RAISE; END INDICATE_USER_IS_LOGGED_OUT; FUNCTION USER_IS_LOGGED_IN ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN BOOLEAN IS BEGIN IF FTP_PARAMETERS.LOCAL_LOGIN_STATUS = LOGGED_IN THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END USER_IS_LOGGED_IN; PROCEDURE INDICATE_TELNET_LINK_OPEN ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ) IS BEGIN FTP_PARAMETERS.TELNET_STATUS := TELNET_LINK_OPEN ; FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" Telnet link opened"); RETURN; EXCEPTION WHEN OTHERS => RAISE; END INDICATE_TELNET_LINK_OPEN; PROCEDURE INDICATE_TELNET_LINK_CLOSED ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC ) IS BEGIN FTP_PARAMETERS.TELNET_STATUS := TELNET_LINK_CLOSED ; FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" Telnet link closed"); RETURN; EXCEPTION WHEN OTHERS => RAISE; END INDICATE_TELNET_LINK_CLOSED; FUNCTION TELNET_LINK_IS_OPEN ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN BOOLEAN IS BEGIN IF FTP_PARAMETERS.TELNET_STATUS = TELNET_LINK_OPEN THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; END TELNET_LINK_IS_OPEN; FUNCTION GET_CURRENT_PORT ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST IS ARGUMENT : FTP_TYPES.ARGUMENT_LIST := FTP_TYPES.NULL_ARGUMENT; ARGUMENT_INDEX : BIT_COUNT_16_TYPE := ARGUMENT'FIRST; BEGIN FOR INDEX IN FTP_TYPES.PORT_ID'RANGE LOOP ARGUMENT( ARGUMENT_INDEX ) := FTP_TYPES.ARGUMENT_LIST_UNIT'(FTP_PARAMETERS.PORT_ID(INDEX)); ARGUMENT_INDEX := ARGUMENT_INDEX +1; END LOOP; RETURN ARGUMENT; EXCEPTION WHEN OTHERS => FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" GET_CURRENT_PORT failed"); RAISE; END GET_CURRENT_PORT; FUNCTION GET_CURRENT_TYPE ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST IS ARGUMENT : FTP_TYPES.ARGUMENT_LIST := FTP_TYPES.NULL_ARGUMENT; BEGIN ARGUMENT( ARGUMENT'FIRST ):= FTP_PARAMETERS.FILE_TYPE ; ARGUMENT( ARGUMENT'FIRST+1 ):= FTP_TYPES.ARGUMENT_LIST_UNIT'(' '); ARGUMENT( ARGUMENT'FIRST+2 ):= FTP_PARAMETERS.CARRIAGE_CONTROL ; RETURN ARGUMENT; EXCEPTION WHEN OTHERS => FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" GET_CURRENT_TYPE failed"); RAISE; END GET_CURRENT_TYPE; FUNCTION GET_CURRENT_CARRIAGE_CONTROL ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST IS ARGUMENT : FTP_TYPES.ARGUMENT_LIST := FTP_TYPES.NULL_ARGUMENT; BEGIN ARGUMENT ( ARGUMENT'FIRST ) := FTP_PARAMETERS.CARRIAGE_CONTROL ; RETURN ARGUMENT; EXCEPTION WHEN OTHERS => FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" GET_CURRENT_CARRIAGE_CONTROL failed"); RAISE; END GET_CURRENT_CARRIAGE_CONTROL; FUNCTION GET_CURRENT_STRUCTURE ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST IS ARGUMENT : FTP_TYPES.ARGUMENT_LIST := FTP_TYPES.NULL_ARGUMENT; BEGIN ARGUMENT ( ARGUMENT'FIRST ) := FTP_PARAMETERS.FILE_STRUCTURE ; RETURN ARGUMENT; EXCEPTION WHEN OTHERS => FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" GET_CURRENT_STRUCTURE failed"); RAISE; END GET_CURRENT_STRUCTURE; FUNCTION GET_CURRENT_MODE ( FTP_PARAMETERS : IN FTP_PARAMETERS_SPEC ) RETURN FTP_TYPES.ARGUMENT_LIST IS ARGUMENT : FTP_TYPES.ARGUMENT_LIST := FTP_TYPES.NULL_ARGUMENT; BEGIN ARGUMENT ( ARGUMENT'FIRST ) := FTP_PARAMETERS.FILE_MODE ; RETURN ARGUMENT; EXCEPTION WHEN OTHERS => FTP_TERMINAL_DRIVER.OUTPUT_MESSAGE_WITH_NEW_LINE (" GET_CURRENT_MODE failed"); RAISE; END GET_CURRENT_MODE; PROCEDURE CHANGE_FILE_STRUCTURE ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST )IS NEW_FILE_STRUCTURE : FTP_TYPES.ARGUMENT_LIST; BEGIN INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( STATUS ); FTP_COMMAND_UTILITIES.GET_FIRST_ARGUMENT_FROM_ARGUMENT_LIST ( ARGUMENT, NEW_FILE_STRUCTURE ); --PUT (" ~~ Stru argument = "); --PUT ( CHARACTER'(NEW_FILE_STRUCTURE(NEW_FILE_STRUCTURE'FIRST))); --NEW_LINE; IF SITE_DETAILS.STRUCTURE_SUPPORTED ( NEW_FILE_STRUCTURE ) THEN FTP_PARAMETERS.FILE_STRUCTURE := FTP_TYPES.ARGUMENT_LIST_UNIT' (NEW_FILE_STRUCTURE(NEW_FILE_STRUCTURE'FIRST)); INDICATE_COMMAND_WAS_SUCCESSFUL ( STATUS ); END IF; --PUT (" ~~ File stru is "); --put ( character'(ftp_parameters.file_structure ) ); --new_line; RETURN; EXCEPTION WHEN OTHERS => -- MY_DEBUG_IO.PUT_LINE (" ~~ ERROR IN CHANGE_FILE_STRUCTURE ~~"); RAISE; END CHANGE_FILE_STRUCTURE ; PROCEDURE CHANGE_FILE_TYPE ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) IS NEW_FILE_TYPE : FTP_TYPES.ARGUMENT_LIST; NEW_CARRIAGE_CONTROL : FTP_TYPES.ARGUMENT_LIST; BEGIN INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( STATUS ); FTP_COMMAND_UTILITIES.GET_FIRST_ARGUMENT_FROM_ARGUMENT_LIST ( ARGUMENT, NEW_FILE_TYPE ); --PUT (" ~~ Type argument = "); --PUT ( CHARACTER'(NEW_FILE_TYPE(NEW_FILE_TYPE'FIRST))); --NEW_LINE; FTP_COMMAND_UTILITIES.GET_SECOND_ARGUMENT_FROM_ARGUMENT_LIST ( ARGUMENT, NEW_CARRIAGE_CONTROL ); --PUT (" ~~ CC argument = "); --PUT ( CHARACTER'(NEW_CARRIAGE_CONTROL(NEW_CARRIAGE_CONTROL'FIRST))); --NEW_LINE; IF (SITE_DETAILS.TYPE_SUPPORTED ( NEW_FILE_TYPE )) AND THEN (SITE_DETAILS.PRINT_TYPE_SUPPORTED (NEW_CARRIAGE_CONTROL)) THEN FTP_PARAMETERS.FILE_TYPE := FTP_TYPES.ARGUMENT_LIST_UNIT' (NEW_FILE_TYPE(NEW_FILE_TYPE'FIRST)); FTP_PARAMETERS.CARRIAGE_CONTROL := FTP_TYPES.ARGUMENT_LIST_UNIT' (NEW_CARRIAGE_CONTROL(NEW_CARRIAGE_CONTROL'FIRST)); INDICATE_COMMAND_WAS_SUCCESSFUL ( STATUS ); END IF; --PUT (" ~~ New file type is "); --put ( character'(ftp_parameters.file_type ) ); --new_line; --PUT (" ~~ New carriage control is "); --put ( character'(ftp_parameters.carriage_control ) ); --new_line; RETURN; EXCEPTION WHEN OTHERS => RAISE; --PUT_LINE (" ~~ ERROR IN CHANGE_FILE_TYPE ~~"); END CHANGE_FILE_TYPE ; PROCEDURE CHANGE_FILE_MODE ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) IS NEW_FILE_MODE : FTP_TYPES.ARGUMENT_LIST; BEGIN INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( STATUS ); FTP_COMMAND_UTILITIES.GET_FIRST_ARGUMENT_FROM_ARGUMENT_LIST ( ARGUMENT, NEW_FILE_MODE ); --PUT (" ~~ Mode argument = "); --PUT ( CHARACTER'(NEW_FILE_MODE(NEW_FILE_MODE'FIRST))); --NEW_LINE; IF SITE_DETAILS.MODE_SUPPORTED ( NEW_FILE_MODE ) THEN FTP_PARAMETERS.FILE_MODE := FTP_TYPES.ARGUMENT_LIST_UNIT' (NEW_FILE_MODE(NEW_FILE_MODE'FIRST)); INDICATE_COMMAND_WAS_SUCCESSFUL ( STATUS ); END IF; --PUT (" ~~ File mode is "); --put ( character'(ftp_parameters.file_mode ) ); --new_line; RETURN; EXCEPTION WHEN OTHERS => RAISE; --PUT_LINE (" ~~ ERROR IN CHANGE_FILE_MODE ~~"); END CHANGE_FILE_MODE ; PROCEDURE GET_PORT_ID_FROM_ARGUMENT ( STATUS : OUT COMMAND_STATUS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST; NEW_PORT_ID : OUT FTP_TYPES.PORT_ID ) IS --&MT PORT_OFFSET : BIT_COUNT_16_TYPE := FTP_TYPES.PORT_ID'FIRST; PORT_OFFSET : BIT_COUNT_32_TYPE := FTP_TYPES.PORT_ID'FIRST; ARGUMENT_OFFSET : BIT_COUNT_16_TYPE := FTP_TYPES.ARGUMENT_LIST'FIRST; BEGIN FOR INDEX IN NEW_PORT_ID'RANGE LOOP NEW_PORT_ID(INDEX) := FTP_TYPES.VALID_PORT_IDENTIFIER'(' '); END LOOP; INDICATE_COMMAND_WAS_SUCCESSFUL ( STATUS ); FOR LOOP_CONTROL IN NEW_PORT_ID'RANGE LOOP IF FTP_TYPES.END_OF_ARGUMENT(ARGUMENT(ARGUMENT_OFFSET)) THEN INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( STATUS ); EXIT; ELSE NEW_PORT_ID ( PORT_OFFSET ) := FTP_TYPES.VALID_PORT_IDENTIFIER'(ARGUMENT(ARGUMENT_OFFSET)); PORT_OFFSET := PORT_OFFSET + 1; ARGUMENT_OFFSET := ARGUMENT_OFFSET + 1; END IF; END LOOP; RETURN; EXCEPTION WHEN OTHERS => INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( STATUS ); END GET_PORT_ID_FROM_ARGUMENT; PROCEDURE CHANGE_PORT ( STATUS : OUT COMMAND_STATUS_SPEC; FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) IS NEW_PORT_ID : FTP_TYPES.PORT_ID; TEMP_STATUS : COMMAND_STATUS_SPEC; BEGIN GET_PORT_ID_FROM_ARGUMENT ( TEMP_STATUS, ARGUMENT, NEW_PORT_ID ); IF COMMAND_WAS_SUCCESSFUL ( TEMP_STATUS ) THEN FTP_PARAMETERS.PORT_ID := NEW_PORT_ID; END IF; RETURN; STATUS := TEMP_STATUS; EXCEPTION WHEN OTHERS => INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( TEMP_STATUS ); STATUS := TEMP_STATUS ; --PUT_LINE (" ~~ ERROR IN CHANGE_PORT~~"); END CHANGE_PORT; PROCEDURE INDICATE_COMMAND_WAS_SUCCESSFUL ( COMMAND_STATUS : OUT COMMAND_STATUS_SPEC ) IS BEGIN COMMAND_STATUS := SUCCESSFUL_COMMAND; RETURN; EXCEPTION WHEN OTHERS => RAISE; --PUT_LINE (" ~~ ERROR IN INDICATE_COMMAND_WAS_SUCCESSFUL ~~"); END INDICATE_COMMAND_WAS_SUCCESSFUL; PROCEDURE INDICATE_COMMAND_WAS_NOT_SUCCESSFUL ( COMMAND_STATUS : OUT COMMAND_STATUS_SPEC ) IS BEGIN COMMAND_STATUS := COMMAND_FAILED; RETURN; EXCEPTION WHEN OTHERS => RAISE; --PUT_LINE(" ~~ ERROR IN INDICATE_COMMAND_WAS_NOT_SUCCESSFUL~~"); END INDICATE_COMMAND_WAS_NOT_SUCCESSFUL; FUNCTION COMMAND_WAS_SUCCESSFUL ( COMMAND_STATUS : IN COMMAND_STATUS_SPEC ) RETURN BOOLEAN IS BEGIN IF COMMAND_STATUS = SUCCESSFUL_COMMAND THEN RETURN TRUE; ELSE RETURN FALSE; END IF; EXCEPTION WHEN OTHERS => RAISE; --PUT_LINE (" ~~ ERROR IN COMMAND_WAS_SUCCESSFUL ~~"); END COMMAND_WAS_SUCCESSFUL; -- -- The following procedures are used during file transfer -- to convert from one data format to another. They are -- implementation dependent. -- PROCEDURE CONVERT_TO_NON_PRINT_CARRIAGE_CONTROL IS BEGIN RETURN; END CONVERT_TO_NON_PRINT_CARRIAGE_CONTROL; PROCEDURE CONVERT_TO_ASA_CARRIAGE_CONTROL IS BEGIN RETURN; END CONVERT_TO_ASA_CARRIAGE_CONTROL ; PROCEDURE CONVERT_TO_TELNET_CARRIAGE_CONTROL IS BEGIN RETURN; END CONVERT_TO_TELNET_CARRIAGE_CONTROL ; PROCEDURE CONVERT_TO_RECORD_STRUCTURE IS BEGIN RETURN; END CONVERT_TO_RECORD_STRUCTURE ; PROCEDURE CONVERT_TO_FILE_STRUCTURE IS BEGIN RETURN; END CONVERT_TO_FILE_STRUCTURE; PROCEDURE CONVERT_FROM_NON_PRINT_CARRIAGE_CONTROL IS BEGIN RETURN; END CONVERT_FROM_NON_PRINT_CARRIAGE_CONTROL; PROCEDURE CONVERT_FROM_ASA_CARRIAGE_CONTROL IS BEGIN RETURN; END CONVERT_FROM_ASA_CARRIAGE_CONTROL ; PROCEDURE CONVERT_FROM_TELNET_CARRIAGE_CONTROL IS BEGIN RETURN; END CONVERT_FROM_TELNET_CARRIAGE_CONTROL ; PROCEDURE CONVERT_FROM_RECORD_STRUCTURE IS BEGIN RETURN; END CONVERT_FROM_RECORD_STRUCTURE ; PROCEDURE CONVERT_FROM_FILE_STRUCTURE IS BEGIN RETURN; END CONVERT_FROM_FILE_STRUCTURE; PROCEDURE OPEN_TELNET_LINK ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) IS TELNET_STATUS : FTP_TELNET.TELNET_STATUS_SPEC; BEGIN FTP_TELNET.OPEN_TELNET_LINK ( TELNET_STATUS, ARGUMENT ); IF FTP_TELNET.TELNET_WAS_SUCCESSFUL ( TELNET_STATUS ) THEN INDICATE_TELNET_LINK_OPEN ( FTP_PARAMETERS ); ELSE INDICATE_TELNET_LINK_CLOSED ( FTP_PARAMETERS ); END IF; RETURN; EXCEPTION WHEN OTHERS => RAISE; END OPEN_TELNET_LINK; PROCEDURE CLOSE_TELNET_LINK ( FTP_PARAMETERS : IN OUT FTP_PARAMETERS_SPEC; ARGUMENT : IN FTP_TYPES.ARGUMENT_LIST ) IS TELNET_STATUS : FTP_TELNET.TELNET_STATUS_SPEC; BEGIN FTP_TELNET.CLOSE_TELNET_LINK ( TELNET_STATUS, ARGUMENT ); IF FTP_TELNET.TELNET_WAS_SUCCESSFUL ( TELNET_STATUS ) THEN INDICATE_TELNET_LINK_CLOSED ( FTP_PARAMETERS ); ELSE INDICATE_TELNET_LINK_OPEN ( FTP_PARAMETERS ); END IF; RETURN; EXCEPTION WHEN OTHERS => RAISE; END CLOSE_TELNET_LINK; BEGIN NULL; EXCEPTION WHEN OTHERS => --PUT_LINE (" Error in Ftp_utils"); RAISE; END FTP_UTILITIES; --:::::::::::::: --ftpsrvutl_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01099-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVUTL_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVUTL AUTHOR : MARK VOLPE -- 5/20/85 8:37 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 9:46 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 10:16 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io, Ftp_types, Ftp_command_utilities, Reply_types, Reply_utilities; PACKAGE Server_utilities IS PROCEDURE Assign ( Reply_code : OUT Reply_types.telnet_reply_code_spec; Code_string : IN STRING ) ; ---------------------------------------------------------------------- -- -- This procedure assigns a value to a reply_code -- ---------------------------------------------------------------------- PROCEDURE Send_system_help_message; ---------------------------------------------------------------------- -- -- This procedure send the system help reply over telnet -- ---------------------------------------------------------------------- PROCEDURE Send_reply_over_telnet ( Reply_message : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure sends a reply over telnet -- ---------------------------------------------------------------------- PROCEDURE Send_reply_over_telnet ( Reply_code_string : IN STRING ); ---------------------------------------------------------------------- -- -- This procedure sends a reply over telnet given only the code -- ---------------------------------------------------------------------- PROCEDURE Assign ( Reply_message : OUT Ftp_types.argument_list ; Message_text : IN STRING ) ; ---------------------------------------------------------------------- -- -- This procedure assigns a reply message a certain text string -- ---------------------------------------------------------------------- PROCEDURE Send_message ( Reply_text : IN STRING ); ---------------------------------------------------------------------- -- -- This procedure sends a reply message via telnet -- ---------------------------------------------------------------------- END Server_utilities; --:::::::::::::: --ftpsrvutl.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01100-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVUTL.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVUTL AUTHOR : MARK VOLPE -- 5/20/85 8:37 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 9:46 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 10:21 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE WAS ADDED TO GIVE FTPSRVUTL.ADA ACCESS TO TEXT_IO : WITH TEXT_IO; PACKAGE BODY Server_utilities IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PROCEDURE Assign ( Reply_code : OUT Reply_types.telnet_reply_code_spec; Code_string : IN STRING ) IS --&MT Code_string_index : BIT_COUNT_16_TYPE := Code_string'first; Code_string_index : BIT_COUNT_32_TYPE := Code_string'first; BEGIN -- My_debug_io.put_line(" Assigning(1)"); FOR Index IN Reply_code'RANGE LOOP Reply_code( Index ) := Reply_types.valid_reply_code_character' ( Code_string( Code_string_index )); Code_string_index := Code_string_index + 1; END LOOP; -- My_debug_io.put_line(" Finished assigning(1)"); EXCEPTION WHEN OTHERS => RAISE; END Assign; PROCEDURE Assign( Reply_message : OUT Ftp_types.argument_list ; Message_text : IN STRING ) IS Reply_index : BIT_COUNT_16_TYPE := Reply_message'FIRST; BEGIN -- My_debug_io.put_line(" Assigning(2)"); Reply_message := Ftp_types.null_argument; FOR Index IN Message_text'RANGE LOOP Reply_message( Reply_index ) := Message_text( Index ); Reply_index := Reply_index + 1; END LOOP; -- My_debug_io.put_line(" Finished assigning(2)"); EXCEPTION WHEN OTHERS => RAISE ; END Assign; PROCEDURE Send_message ( Reply_text : IN STRING ) IS Reply_message : Ftp_types.argument_list ; BEGIN -- My_debug_io.put_line(" Sending message over telnet"); Assign ( Reply_message, Reply_text ); Send_reply_over_telnet ( Reply_message ); -- My_debug_io.put_line(" Finished sending message over telnet"); EXCEPTION WHEN OTHERS => Raise; END Send_message; PROCEDURE Send_system_help_message is BEGIN Send_message(" The following are recognized commands at this site" ); Send_message(" USER - Logs the user onto this system (needs username)"); Send_message(" PASS - Required after USER" ); Send_message(" QUIT - Logs user off and closes telnet connection" ); Send_message(" NOOP - Sends a noop command to the remote system" ); Send_message(" PORT - Changes the data transfer port for this system" ); Send_message(" TYPE - Changes the data transfer type and " & "carriage control used in file transfer" ); Send_message(" MODE - Changes the data transfer mode used " & "in file transfer" ); Send_message(" STRU - Changes the data transfer structure " & "used in file transfer" ); Send_message(" HELP - Outputs this message" ); Send_message(" STOR - Copies a file from another system to this system"); Send_message(" RETR - Sends a copy of a file to another system" ); EXCEPTION WHEN OTHERS => RAISE; END Send_system_help_message; PROCEDURE Send_reply_over_telnet ( Reply_message : IN Ftp_types.argument_list ) IS Xmit_status : Ftp_command_utilities.transmission_status_spec; Xmit_failure: EXCEPTION; BEGIN -- My_debug_io.put_line(" Sending reply(1) over telnet"); Ftp_command_utilities.send_command_over_telnet ( Xmit_status, Ftp_types.reply_command, Reply_message ); IF NOT Ftp_command_utilities.transmission_successful(xmit_status) THEN RAISE Xmit_failure; END IF; -- My_debug_io.put_line(" Finished sending reply(1) over telnet"); EXCEPTION WHEN OTHERS => RAISE; END Send_reply_over_telnet; PROCEDURE Send_reply_over_telnet ( Reply_code_string : IN STRING) IS Reply_code : Reply_types.telnet_reply_code_spec; Reply_message : Ftp_types.argument_list; BEGIN -- My_debug_io.put_line(" Sending reply(2) over telnet"); Assign ( Reply_code, Reply_code_string ); Reply_utilities.add_text_to_reply( Reply_code, Reply_message ); Send_reply_over_telnet ( Reply_message ); -- My_debug_io.put_line(" Finished sending reply(2) over telnet"); EXCEPTION WHEN OTHERS => RAISE; END Send_reply_over_telnet; BEGIN NULL; EXCEPTION WHEN OTHERS => RAISE; END Server_utilities; --:::::::::::::: --ftpsrvlog_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01095-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVLOG_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVLOG AUTHOR : MARK VOLPE -- 5/20/85 9:08 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:10 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 10:37 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io, Ftp_types, Server_utilities, Ftp_telnet, Ftp_utilities; USE My_debug_io, Ftp_types, Server_utilities, Ftp_telnet, Ftp_utilities; PACKAGE Server_login_commands IS PROCEDURE Logout ( Ftp_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) ; ---------------------------------------------------------------------- -- -- This procedure logs the user out but leaves telnet open. -- No replies are sent over telnet. -- ---------------------------------------------------------------------- PROCEDURE Log_user_onto_system ( Status : OUT Ftp_utilities.command_status_spec; Ftp_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure logs the user onto the system. -- If the user is already logged in then he is logged out and -- re-logged in under the new user name. -- A reply is sent indicating the login status. -- ---------------------------------------------------------------------- PROCEDURE Log_user_off_of_system ( Status : OUT Ftp_utilities.command_status_spec; Ftp_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure logs the user off of the system and closes the telnet -- connection. -- A reply is sent indicating the login status. -- ---------------------------------------------------------------------- END Server_login_commands; --:::::::::::::: --ftpsrvlog.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01096-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVLOG.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVLOG AUTHOR : MARK VOLPE -- 5/20/85 9:08 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:10 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 10:40 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/18/85 4:46 PM : relpy_message => "xxx" to reply_code_string => "xxx" PACKAGE BODY Server_login_commands IS Logout_error : EXCEPTION; PROCEDURE Logout ( Ftp_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS BEGIN --D My_debug_io.put_line(" Logging user off of system "); Indicate_user_is_logged_out ( Ftp_parameters ); EXCEPTION WHEN OTHERS => RAISE Logout_error; END Logout; PROCEDURE Log_user_onto_system ( Status : OUT Ftp_utilities.command_status_spec; Ftp_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS BEGIN IF User_is_logged_in ( Ftp_parameters ) THEN Logout ( Ftp_parameters ); END IF; NULL; -- log user in Indicate_user_is_logged_in ( Ftp_parameters ); Indicate_command_was_successful ( Status ); --&MT Send_reply_over_telnet("230"); Send_reply_over_telnet(reply_code_string => "230"); EXCEPTION WHEN Logout_error => -- Still logged in under old username --D My_debug_io.put_line(" Logout error in Log_user_onto_system "); Indicate_command_was_not_successful ( Status ); --&MT Send_reply_over_telnet("500"); Send_reply_over_telnet( reply_code_string => "500"); WHEN OTHERS => --D My_debug_io.put_line (" Unknown error in Log_user_onto_system"); Indicate_command_was_not_successful ( Status ); --&MT Send_reply_over_telnet("530"); Send_reply_over_telnet( reply_code_string => "530"); RAISE; END Log_user_onto_system; PROCEDURE Log_user_off_of_system ( Status : OUT Ftp_utilities.command_status_spec ; Ftp_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ; Argument : IN Ftp_types.argument_list ) IS Telnet_status : Ftp_telnet.telnet_status_spec; BEGIN --D My_debug_io.put_line (" Logging user off of system "); Logout ( Ftp_parameters ); Indicate_command_was_successful ( Status ); --&MT Send_reply_over_telnet("221"); Send_reply_over_telnet( reply_code_string => "221" ); Close_telnet_link ( Telnet_status, Argument ); --D My_debug_io.put_line(" User logged off of system "); EXCEPTION WHEN OTHERS => Indicate_command_was_not_successful ( Status ); --D My_debug_io.put_line(" Unknown error - Log_user_off_of_system"); --&MT Send_reply_over_telnet("421"); Send_reply_over_telnet( reply_code_string => "421"); RAISE; END Log_user_off_of_system; BEGIN NULL; EXCEPTION WHEN OTHERS => NULL; --D My_debug_io.put_line (" Unknown error in SERVER_LOGIN "); END Server_login_commands; --:::::::::::::: --ftpsrvdtp_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01093-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVDTP_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVDTP AUTHOR : MARK VOLPE -- 5/20/85 9:39 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:29 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 10:50 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH Ftp_types, Ftp_utilities, Site_details, Server_utilities; PACKAGE Server_dtp_commands IS ---------------------------------------------------------------------- -- -- This package contains procedures to process comannds which -- effect the server's dtp. -- ---------------------------------------------------------------------- PROCEDURE Change_default_structure ( status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure changes the file structure to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE Change_default_type ( status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure changes the file type to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE Change_default_mode ( Status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure changes the file mode to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- PROCEDURE Change_default_port ( Status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure changes the transmit port to be used during -- file transfers which use tcp. -- ---------------------------------------------------------------------- END Server_dtp_commands ; --:::::::::::::: --ftpsrvdtp.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01094-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVDTP.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVDTP AUTHOR : MARK VOLPE -- 5/20/85 9:39 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:29 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 10:55 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/18/85 4:54 PM : relpy_message => "xxx" to reply_code_string => "xxx" PACKAGE BODY Server_dtp_commands IS PROCEDURE Change_default_type ( Status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS temp_status : Ftp_utilities.command_status_spec; BEGIN Ftp_utilities.change_file_type ( temp_status, Server_parameters, Argument ); IF Ftp_utilities.command_was_successful ( temp_status ) THEN --&MT Server_utilities.send_reply_over_telnet ( "200"); Server_utilities.send_reply_over_telnet ( reply_code_string => "200" ); ELSE Ftp_utilities.indicate_command_was_not_successful ( temp_status ); --&MT Server_utilities.send_reply_over_telnet ( "504"); Server_utilities.send_reply_over_telnet ( reply_code_string => "504"); END IF; status := temp_status; EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" CHANGE_DEFAULT_TYPE FAILED "); Ftp_utilities.indicate_command_was_not_successful ( temp_status ); --&MT Server_utilities.send_reply_over_telnet( "500"); Server_utilities.send_reply_over_telnet ( reply_code_string => "500"); status := temp_status ; END Change_default_type; PROCEDURE Change_default_structure ( Status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS temp_status : Ftp_utilities.command_status_spec; BEGIN Ftp_utilities.change_file_structure(temp_status,Server_parameters,Argument); IF Ftp_utilities.command_was_successful ( temp_status ) THEN --&MT Server_utilities.send_reply_over_telnet ( "200"); Server_utilities.send_reply_over_telnet ( reply_code_string => "200"); ELSE Ftp_utilities.indicate_command_was_not_successful( temp_status ); --&MT Server_utilities.send_reply_over_telnet ( "504"); Server_utilities.send_reply_over_telnet ( reply_code_string => "504"); END IF; status := temp_status ; EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" CHANGE_DEFAULT_STRUCTURE FAILED "); Ftp_utilities.indicate_command_was_not_successful( temp_status ); --&MT Server_utilities.send_reply_over_telnet ( "500"); Server_utilities.send_reply_over_telnet ( reply_code_string => "500"); status := temp_status ; END Change_default_structure; PROCEDURE Change_default_mode ( Status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS temp_status : Ftp_utilities.command_status_spec ; BEGIN Ftp_utilities.change_file_mode( temp_status, Server_parameters, Argument ); IF Ftp_utilities.command_was_successful ( temp_status ) THEN --&MT Server_utilities.send_reply_over_telnet ( "200" ); Server_utilities.send_reply_over_telnet ( reply_code_string => "200"); ELSE --&MT Server_utilities.send_reply_over_telnet ( "504" ); Server_utilities.send_reply_over_telnet ( reply_code_string => "504"); Ftp_utilities.indicate_command_was_not_successful( temp_status ); END IF; status := temp_status ; EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" CHANGE_DEFAULT_MODE FAILED "); Ftp_utilities.indicate_command_was_not_successful( temp_status ); --&MT Server_utilities.send_reply_over_telnet ( "500"); Server_utilities.send_reply_over_telnet ( reply_code_string => "500"); status := temp_status ; END Change_default_mode; PROCEDURE Change_default_port ( Status : out Ftp_utilities.command_status_spec; Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS temp_status : Ftp_utilities.command_status_spec; BEGIN IF Site_details.specified_host_is_this_host ( Argument ) THEN Ftp_utilities.change_port( temp_status, Server_parameters, Argument ); IF Ftp_utilities.command_was_successful ( temp_status ) THEN --&MT Server_utilities.send_reply_over_telnet( "200"); Server_utilities.send_reply_over_telnet ( reply_code_string => "200"); ELSE --&MT Server_utilities.send_reply_over_telnet( "501"); Server_utilities.send_reply_over_telnet ( reply_code_string => "501"); Ftp_utilities.indicate_command_was_not_successful( temp_status ); END IF; ELSE --&MT Server_utilities.send_reply_over_telnet( "501"); Server_utilities.send_reply_over_telnet ( reply_code_string => "501"); Ftp_utilities.indicate_command_was_not_successful( temp_status ); END IF; status := temp_status ; EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" CHANGE_DEFAULT_PORT FAILED "); Ftp_utilities.indicate_command_was_not_successful( temp_status ); --&MT Server_utilities.send_reply_over_telnet ( "500"); Server_utilities.send_reply_over_telnet ( reply_code_string => "500"); status := temp_status ; END Change_default_port; BEGIN NULL; EXCEPTION WHEN OTHERS => NULL; --D My_debug_io.put_line (" Unknown error in Server_dtp_commands"); END Server_dtp_commands; --:::::::::::::: --ftpsrvpi_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01097-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVPI_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVPI AUTHOR : MARK VOLPE -- 5/20/85 3:38 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:43 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 11:04 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH Ftp_types, Reply_types, Reply_utilities, Server_utilities, Ftp_utilities; PACKAGE Server_pi_commands IS ---------------------------------------------------------------------- -- -- This package contains procedures to procces commands which -- effect the server pi. -- ---------------------------------------------------------------------- PROCEDURE Process_noop_from_user_pi ( status : out Ftp_utilities.command_status_spec ); ---------------------------------------------------------------------- -- -- This procedure sends a reply code of '200' to -- the user's system. -- ---------------------------------------------------------------------- PROCEDURE Process_help_from_user_pi ( status : out Ftp_utilities.command_status_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- This procedure sends helpful information -- to the user via telnet. The data is sent as -- a multiline reply. -- ---------------------------------------------------------------------- END Server_pi_commands; --:::::::::::::: --ftpsrvpi.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01098-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVPI.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVPI AUTHOR : MARK VOLPE -- 5/20/85 3:38 PM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:43 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 11:05 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/18/85 5:05 PM : relpy_message => "xxx" to reply_code_string => "xxx" PACKAGE BODY Server_pi_commands IS PROCEDURE Process_noop_from_user_pi ( status : out Ftp_utilities.command_status_spec ) IS BEGIN Ftp_utilities.indicate_command_was_successful( Status ); --&MT Server_utilities.send_reply_over_telnet ( "200" ); Server_utilities.send_replY_over_telnet ( reply_code_string => "200"); EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" PROCESS_NOOP FAILED"); --&MT Server_utilities.send_reply_over_telnet ( "200" ); Server_utilities.send_replY_over_telnet ( reply_code_string => "200"); Ftp_utilities.indicate_command_was_not_successful( Status ); END Process_noop_from_user_pi; PROCEDURE Process_help_from_user_pi ( status : out Ftp_utilities.command_status_spec; Argument : IN Ftp_types.argument_list ) IS Reply_message : Ftp_types.argument_list; Reply_code : Reply_types.telnet_reply_code_spec; BEGIN -- -- Leave this in long form -- Ftp_utilities.indicate_command_was_successful( Status); Server_utilities.assign ( Reply_code, "214"); Reply_utilities.add_text_to_reply( Reply_code, Reply_message); Reply_utilities.indicate_multiline_reply( Reply_message ); Server_utilities.send_reply_over_telnet( Reply_message ); Server_utilities.send_system_help_message; Server_utilities.assign ( Reply_code, "214"); Reply_utilities.add_text_to_reply( Reply_code, Reply_message); Server_utilities.send_reply_over_telnet( Reply_message ); EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" PROCESS_HELP FAILED"); --&MT Server_utilities.send_reply_over_telnet ( "500" ); Server_utilities.send_replY_over_telnet ( reply_code_string => "500"); Ftp_utilities.indicate_command_was_not_successful( STATUS ); END Process_help_from_user_pi; BEGIN NULL; EXCEPTION WHEN OTHERS => --D My_debug_io.put_line (" Error in server_pi_commands "); RAISE; END Server_pi_commands ; --:::::::::::::: --ftpsrvxfr_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01101-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVXFR_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVXFR AUTHOR : MARK VOLPE -- 5/21/85 8:16 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:51 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 1:35 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io; WITH Server_utilities; USE Server_utilities; WITH FTP_COMMAND_UTILITIES; USE Ftp_command_utilities; WITH Ftp_types; USE Ftp_types; WITH Ftp_utilities; USE Ftp_utilities; WITH Ftp_file_io; USE Ftp_file_io; WITH Ftp_tcp; USE Ftp_tcp; PACKAGE Server_xfer_commands IS ---------------------------------------------------------------------- -- -- This package contains procedures used by the server system during -- file transfers. -- ---------------------------------------------------------------------- PROCEDURE Accept_file_user_to_server ( Status : OUT FTP_UTILITIES.COMMAND_STATUS_SPEC; Server_parameters : IN FTP_UTILITIES.FTP_PARAMETERS_SPEC; Argument : IN FTP_TYPES.ARGUMENT_LIST ); ---------------------------------------------------------------------- -- -- This procedure performs the handshaking required to accept -- a file from the user system via tcp. The actual transfer is done -- with a procedure call. -- ( STOR ) ---------------------------------------------------------------------- PROCEDURE Send_file_server_to_user ( Status : OUT FTP_UTILITIES.COMMAND_STATUS_SPEC; Server_parameters : IN FTP_UTILITIES.FTP_PARAMETERS_SPEC; Argument : IN FTP_TYPES.ARGUMENT_LIST ); ---------------------------------------------------------------------- -- -- This procedure performs the handshaking required to send -- a file from the server to the user system via tcp. -- The actual transfer is done with a procedure call. -- ( RETR ) ---------------------------------------------------------------------- END Server_xfer_commands; --:::::::::::::: --ftpsrvxfr.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01102-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSRVXFR.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSRVXFR AUTHOR : MARK VOLPE -- 5/21/85 8:16 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 10:51 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 7/10/85 6:30 PM : global_tcp_identifier added -- 7/18/85 5:11 PM : relpy_message => "xxx" to reply_code_string => "xxx" -- 7/19/85 11:31 AM : do send_the_file after opening connection in -- : set_up_tcp_and_send_file -- 4:22 PM : close data link in send_file_server_to user -- 7/24/85 1:40 AM : don't close file in set_up_and_send_file --&MT THE FOLLOWING LINE WAS ADDED TO GIVE FTPSRVXFR.ADA ACCESS TO TEXT_IO : WITH TEXT_IO ; PACKAGE BODY Server_xfer_commands IS Transfer_failed : EXCEPTION; Transfer_failure_handled : EXCEPTION; --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); global_tcp_identifier : FTP_TCP.TCP_IDENTIFIER_SPEC ; PROCEDURE Send_the_file ( Tcp_identifier : IN OUT FTP_TCP.TCP_IDENTIFIER_SPEC ; Server_parameters : IN FTP_UTILITIES.FTP_PARAMETERS_SPEC ) IS Current_file_structure : Argument_list := Get_current_structure( Server_parameters ); BEGIN IF Current_file_structure(1) = Argument_list_unit'('R') THEN My_debug_io.PUT_LINE (" Sending the file as records "); Send_file_as_records ( Tcp_identifier ); My_debug_io.PUT_LINE (" File has been sent as records "); ELSE My_debug_io.PUT_LINE (" Sending the file as a stream "); Send_file_as_stream ( Tcp_identifier ); My_debug_io.PUT_LINE (" File has been sent as a stream "); END IF; EXCEPTION WHEN OTHERS => -- Including tcp exceptions My_debug_io.PUT_LINE (" Send the file Failed "); My_debug_io.PUT_LINE (" Raising transfer failed "); My_debug_io.put_line (" Closing tcp (2)"); Close_tcp_data_link ( Tcp_identifier ); RAISE ; -- Transfer_failed; END Send_the_file; PROCEDURE Accept_the_file ( Tcp_identifier : IN OUT Ftp_tcp.tcp_identifier_spec ; Server_parameters : IN Ftp_utilities.ftp_parameters_spec ) IS Current_file_structure : Argument_list := Get_current_structure( Server_parameters ); PROCEDURE Give_tcp_time_to_process_before_sending_reply IS I : BIT_COUNT_16_TYPE := 0; BEGIN FOR Time_delay IN 1..10 LOOP FOR Time_delay_2 IN 1..10_000 LOOP I := 0; END LOOP; END LOOP; END Give_tcp_time_to_process_before_sending_reply; BEGIN --&MT Send_reply_over_telnet( "150" ); Send_reply_over_telnet( reply_code_string => "150"); IF Tcp_connection_is_open( Tcp_identifier ) THEN NULL; My_debug_io.put_line(" Tcp already open; receiving the file"); ELSE My_debug_io.put_line(" Opening TCP "); Open_tcp_data_link( Tcp_identifier ); My_debug_io.put_line(" Receiveing the file "); END IF; IF Current_file_structure( Current_file_structure'FIRST ) = Argument_list_unit'('R') THEN My_debug_io.PUT_LINE (" Receiving the file as records "); Receive_file_as_records ( Tcp_identifier ); My_debug_io.PUT_LINE(" The file has been received as records"); ELSE My_debug_io.PUT_LINE (" Receiving the file as a stream "); Receive_file_as_stream ( Tcp_identifier ); My_debug_io.PUT_LINE(" File has been received as a stream"); END IF; My_debug_io.PUT_LINE (" File received; sending reply "); Give_tcp_time_to_process_before_sending_reply; --&MT Send_reply_over_telnet( "226" ); Send_reply_over_telnet( reply_code_string => "226"); My_debug_io.PUT_LINE (" Reply sent, Tcp data link closed "); EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" Accept the file Failed "); My_debug_io.PUT_LINE (" Raising transfer failed "); RAISE ; -- Transfer_failed; END Accept_the_file; PROCEDURE Accept_file_user_to_server ( Status : OUT FTP_UTILITIES.COMMAND_STATUS_SPEC; Server_parameters : IN FTP_UTILITIES.FTP_PARAMETERS_SPEC; Argument : IN FTP_TYPES.ARGUMENT_LIST ) IS File_name_string : --&MT STRING( Argument'FIRST..Argument'LAST); STRING( bit_count_32_type(Argument'FIRST)..bit_count_32_type(Argument'LAST)); File_name_length : BIT_COUNT_16_TYPE; File_name_from_argument : Ftp_types.argument_list; Tcp_identifier : Ftp_tcp.tcp_identifier_spec := global_tcp_identifier ; PROCEDURE Create_output_file IS BEGIN My_debug_io.put_line (" Creating file"); Get_first_argument_from_argument_list ( Argument, File_name_from_argument ); Convert_argument_to_string (File_name_from_argument,File_name_string,File_name_length); Open_output_file( File_name_string( File_name_string'FIRST .. File_name_string'FIRST + --&MT File_name_length - 1 )); bit_count_32_type(File_name_length) - 1 )); My_debug_io.put_line (" File created "); EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" create output file failed "); My_debug_io.PUT_LINE (" Raising ? "); RAISE; END Create_output_file; BEGIN Indicate_command_was_not_successful( Status ); Create_output_file; -- Initialize_tcp( Tcp_identifier ); -- Debug only Accept_the_file( Tcp_identifier, Server_parameters ); Close_output_file; -- Close_tcp_data_link ( Tcp_identifier ); My_debug_io.PUT_LINE (" Tcp closed, returning "); Indicate_command_was_successful( Status ); global_tcp_identifier := tcp_identifier ; EXCEPTION -- -- If any of these exception routines generate an exception then -- the exception is propagated up. This could be fatal. Consequently, -- send the replies last so that if an exception arises no reply will -- have been sent. -- -- WHEN Create_request_failed => -- Couldn't create output file -- My_debug_io.PUT_LINE(" Accept_file_user_to_server(0) failed"); -- My_debug_io.PUT_LINE (" exception not propagated "); -- Send_reply_over_telnet( "450" ); -- File not avaliable -- Send_reply_over_telnet( reply_code_string => "450"); -- WHEN FTP_TCP.Tcp_request_failed | -- Unexpected_reply | -- Tcp_connection_closed | -- Tcp_aborted | -- No_more_tcp_data => -- My_debug_io.PUT_LINE(" Accept_file_user_to_server(1) failed "); -- My_debug_io.put_line (" Shutting down system "); -- Close_output_file; -- Might raise error_closing_file -- IF Tcp_connection_is_open ( Tcp_identifier ) THEN -- Close_tcp_data_link ( Tcp_identifier ); -- Tcp_request_failed? -- END IF; -- Send_reply_over_telnet( "425" ); -- TCP failed -- Send_reply_over_telnet( reply_code_string => "425"); -- WHEN Close_request_failed => -- File is open -- -- Transfer ok, but file still open -- My_debug_io.PUT_LINE(" Accept_file_user_to_server(2) "); -- My_debug_io.put_line (" Shutting down system "); -- Close_tcp_data_link ( Tcp_identifier ); -- Send_reply_over_telnet( "226" ); -- Send_reply_over_telnet( reply_code_string => "226"); -- Indicate_command_was_successful( Status ); WHEN OTHERS => My_debug_io.PUT_LINE(" Accept_file_user_to_server(3) "); My_debug_io.put_line (" Shutting down system "); Close_output_file; -- Might raise error_closing_file Close_tcp_data_link ( Tcp_identifier ); -- Raise tcp_requst_failed? --&MT Send_reply_over_telnet( "426" ); Send_reply_over_telnet( reply_code_string => "426"); END Accept_file_user_to_server; PROCEDURE Send_file_server_to_user ( Status : OUT FTP_UTILITIES.COMMAND_STATUS_SPEC; Server_parameters : IN FTP_UTILITIES.FTP_PARAMETERS_SPEC; Argument : IN FTP_TYPES.ARGUMENT_LIST ) IS File_name_string : --&MT STRING( ARGUMENT'FIRST..ARGUMENT'LAST); STRING( bit_count_32_type(ARGUMENT'FIRST)..bit_count_32_type(ARGUMENT'LAST)); File_name_length : BIT_COUNT_16_TYPE; File_name_from_argument : FTP_TYPES.ARGUMENT_LIST; Tcp_identifier : FTP_TCP.TCP_IDENTIFIER_SPEC := global_tcp_identifier ; PROCEDURE Open_input_file IS BEGIN My_debug_io.PUT_LINE (" Opening file"); Get_first_argument_from_argument_list ( Argument, File_name_from_argument ); Convert_argument_to_string (File_name_from_argument,File_name_string,File_name_length); Open_input_file( File_name_string( File_name_string'FIRST .. File_name_string'FIRST + --&MT File_name_length - 1 )); bit_count_32_type(File_name_length) - 1 )); My_debug_io.PUT_LINE (" File opened"); EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" open input file Failed "); My_debug_io.PUT_LINE (" Raising open request failed "); RAISE Open_request_failed; END Open_input_file; PROCEDURE Set_up_tcp_and_send_file IS BEGIN --&MT Send_reply_over_telnet( "150" ); -- File ok Send_reply_over_telnet( reply_code_string => "150"); IF Tcp_connection_is_open( Tcp_identifier ) THEN My_debug_io.PUT_LINE (" Connection already opened "); Send_the_file( Tcp_identifier, Server_parameters ); ELSE --&MT My_debug_io.PUT_LINE (" Opening connection "); -- DECLARE -- length : integer ; -- st : string (1..80) ; -- begin -- text_io.put_line("wait for other side to do passive open") ; -- text_io.get_line(st, length) ; --&MT end ; Open_tcp_data_link( Tcp_identifier ); Send_the_file( Tcp_identifier , Server_parameters ); END IF; --&MT Send_reply_over_telnet( "226" ); Send_reply_over_telnet( reply_code_string => "226"); EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" set up tcp and send Failed "); My_debug_io.PUT_LINE (" Raising tcp request failed "); RAISE FTP_TCP.Tcp_request_failed; END Set_up_tcp_and_send_file; BEGIN Indicate_command_was_not_successful ( Status ); Open_input_file; -- Initialize_tcp( Tcp_identifier ); -- Debug only Set_up_tcp_and_send_file; Close_input_file; My_debug_io.PUT_LINE (" File closed "); Close_tcp_data_link ( Tcp_identifier ); My_debug_io.PUT_LINE (" Connection closed "); Indicate_command_was_successful ( Status ); global_tcp_identifier := tcp_identifier ; EXCEPTION WHEN OTHERS => My_debug_io.PUT_LINE (" Send_file_server_to_user(4) Failed "); --&MT Send_reply_over_telnet ( "550"); Send_reply_over_telnet( reply_code_string => "550"); END Send_file_server_to_user; BEGIN global_tcp_identifier.local_port_id := 6 ; global_tcp_identifier.connection_status := ftp_tcp.closed ; ftp_tcp.initialize_tcp(global_tcp_identifier) ; EXCEPTION WHEN OTHERS => RAISE; END Server_xfer_commands ; --:::::::::::::: --ftpserver.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01090-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPSERVER.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPSERVER AUTHOR : MARK VOLPE -- 5/21/85 8:56 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 11:27 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 2:07 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 6/22/85 3:41 PM : converted PROCESS_FTP_COMMAND into a task -- added code appended with --&KJW -- 6/24/85 2:30 PM : converted SERVER_TELNET into a task, -- added code appended with --&KJW -- 7/10/85 4:03 PM : change name of server_telnet to server_telnet_package(MT) -- 7/18/85 4:46 PM : relpy_message => "xxx" to reply_code_string => "xxx" --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO (ON); WITH Server_telnet_package, --&KJW My_debug_io, Server_login_commands, Server_pi_commands, -- For pi commands Server_dtp_commands, -- For dtp commands Server_xfer_commands,-- For sending files Server_utilities, Ftp_utilities, Ftp_command_utilities,-- For getting commands from telnet Ftp_types, Ftp_telnet; PROCEDURE Server_ftp IS ---------------------------------------------------------------------- -- -- This procedure is the upper level of FTP on the server (remote) side. -- It is responsibe for interfacing between Telnet and the remote system. -- -- The command is accepted from Telnet. -- The command is then verified and converted to an enumerated type. -- A command handler is then called, base on this enumerated type. -- During command processing, replies are sent back to the user's system -- via telnet. -- ---------------------------------------------------------------------- Server_parameters : Ftp_utilities.ftp_parameters_spec; TelNet_Server : Server_telnet_package.TelNet_Controller; TASK Process_FTP_Command IS --&KJW PRAGMA Priority(7); --&KJW END Process_FTP_Command; --&KJW TASK BODY Process_FTP_Command IS --&KJW --PROCEDURE Process_ftp_command -- ( Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS -- N O T I C E :: What was once parameter "server_parameters" --&KJW -- is now global object "server_parameters" --&KJW ---------------------------------------------------------------------- -- -- THIS PROCEDURE ACCEPTS THE COMMANDS FROM TELNET -- THEN CALLS THE APPROPRIATE COMMAND_HANDLER -- ---------------------------------------------------------------------- Command : Ftp_types.valid_command_spec; Command_status : Ftp_command_utilities.command_status_spec; Argument : Ftp_types.argument_list; Server_command_status: Ftp_utilities.command_status_spec; BEGIN DECLARE Telnet_status : Ftp_telnet.telnet_status_spec; BEGIN Ftp_telnet.wait_for_telnet_open( Telnet_status ); END ; LOOP --D My_debug_io.put_line (" Trying to get a command from telnet"); Ftp_command_utilities.get_command_from_telnet ( Command_status, Command, Argument ); IF Ftp_command_utilities.argument_list_is_valid ( Command_status ) THEN CASE Command IS WHEN Ftp_types.user_command => Server_login_commands.log_user_onto_system ( Server_command_status, Server_parameters, Argument ); WHEN Ftp_types.pass_command => --&MT Server_utilities.send_reply_over_telnet ("503"); Server_utilities.send_reply_over_telnet(reply_code_string => "503"); WHEN Ftp_types.quit_command => Server_login_commands.log_user_off_of_system ( Server_command_status, Server_parameters, Ftp_types.null_argument); EXIT; -- GET US OUT OF LOOP SO WE CAN QUIT WHEN Ftp_types.noop_command => Server_pi_commands.process_noop_from_user_pi ( Server_command_status ); WHEN Ftp_types.help_command => Server_pi_commands.process_help_from_user_pi ( Server_command_status, Argument ); WHEN Ftp_types.stru_command => Server_dtp_commands.change_default_structure ( Server_command_status, Server_parameters, Argument ); WHEN Ftp_types.type_command => Server_dtp_commands.change_default_type ( Server_command_status, Server_parameters, Argument ); WHEN Ftp_types.mode_command => Server_dtp_commands.change_default_mode ( Server_command_status, Server_parameters, Argument ); WHEN Ftp_types.port_command => Server_dtp_commands.change_default_port ( Server_command_status, Server_parameters, Argument ); WHEN Ftp_types.stor_command => Server_xfer_commands.accept_file_user_to_server ( Server_command_status, Server_parameters, Argument ); WHEN Ftp_types.retr_command => Server_xfer_commands.send_file_server_to_user ( Server_command_status, Server_parameters, Argument ); WHEN OTHERS => --&MT Server_utilities.send_reply_over_telnet ("500"); Server_utilities.send_reply_over_telnet(reply_code_string => "500"); END CASE; ELSE --&MT Server_utilities.send_reply_over_telnet ("500"); Server_utilities.send_reply_over_telnet ( reply_code_string => "500"); END IF; END LOOP; END Process_ftp_command; PROCEDURE Server_exception_abort ( Server_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS ---------------------------------------------------------------------- -- -- This procedure shuts down the tcp connection between the server dtp -- and the user dtp; aborting any file transfers in progress. -- It then sends a reply of "451" ( local error in processing ) and -- logs the server off its system. -- ---------------------------------------------------------------------- Server_command_status : Ftp_utilities.command_status_spec; Telnet_status : Ftp_telnet.telnet_status_spec; BEGIN Server_login_commands.logout( Server_parameters ); Ftp_telnet.close_telnet_link( Telnet_status, Ftp_types.null_argument ); EXCEPTION WHEN OTHERS => NULL; -- Don't raise it, kill all exceptions here! END Server_exception_abort; BEGIN -- Process_ftp_command( Server_parameters ); --&KJW TelNet_Server.Connection_Assignments(8,0,0); --&KJW EXCEPTION WHEN OTHERS => Server_exception_abort( Server_parameters ); END Server_ftp; --:::::::::::::: --ftpusrxfr_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01116-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSRXFR_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUSRXFR AUTHOR : MARK VOLPE -- 5/21/85 9:12 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 1:30 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 2:18 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io; USE My_debug_io; WITH Ftp_types; USE Ftp_types; WITH Reply_types; USE Reply_types; WITH Ftp_tcp; USE Ftp_tcp; WITH Reply_utilities; USE Reply_utilities; WITH FTP_COMMAND_UTILITIES; USE FTP_COMMAND_UTILITIES; WITH Ftp_terminal_driver; USE Ftp_terminal_driver; WITH Ftp_utilities; USE Ftp_utilities; WITH Ftp_file_io; USE Ftp_file_io; PACKAGE User_xfer_commands IS ---------------------------------------------------------------------- -- -- This package contains the procedures used by the user ftp -- during data transfers. -- ---------------------------------------------------------------------- PROCEDURE Send_file_user_to_server ( Status : OUT Ftp_utilities.command_status_spec; User_parameters : IN Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); -- -- This procedure sends the file specified in the argument -- list from the user system to the server system. -- Any data transformations that are required are handled -- internally. -- PROCEDURE Accept_file_server_to_user ( Status : OUT Ftp_utilities.command_status_spec; User_parameters : IN Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); -- -- This procedure accepts the file specified in the argument -- list from the server system. -- Any data transformations that are required are handled -- internally. -- END User_xfer_commands; --:::::::::::::: --ftpusrxfr.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01117-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSRXFR.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUSRXFR AUTHOR : MARK VOLPE -- 5/21/85 9:12 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 1:30 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 2:23 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 7/10/85 6:15 PM : global tcp identifier added -- 7/11/85 11:29 AM : don't do passive open -- 7/19/85 11:40 AM : remove -1 port number from pack body init -- 4:33 PM : uncomment debug output lines -- 7/23/85 11:30 PM : don't do close in accept_file_server_to_user -- 7/29/85 1:39 PM : undo above --&MT THE FOLLOWING LINE WAS ADDED TO GIVE FTPUSRXFR.ADA ACCESS TO TEXT_IO : WITH TEXT_IO ; PACKAGE BODY User_xfer_commands IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); global_tcp_identifier : Ftp_tcp.tcp_identifier_spec ; PROCEDURE Send_file_user_to_server ( Status : OUT Ftp_utilities.command_status_spec; User_parameters : IN Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Name_field : Ftp_types.argument_list; File_name : --&MT STRING( Argument'first..argument'last ); STRING( bit_count_32_type(Argument'first)..bit_count_32_type(argument'last) ); File_name_length : BIT_COUNT_16_TYPE := 0; Transmission_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec; Tcp_identifier : Ftp_tcp.tcp_identifier_spec := global_tcp_identifier ; Current_structure : Argument_list; PROCEDURE Send_the_file IS BEGIN Output_message_with_new_line(" Remote file opened, starting transfer"); Current_structure := Get_current_structure ( User_parameters ); IF Current_structure(Current_structure'FIRST)=Argument_list_unit'('R') THEN My_debug_io.Put_line(" Sending file as records "); Send_file_as_records ( Tcp_identifier ); My_debug_io.Put_line(" File sent as records "); ELSE My_debug_io.Put_line(" Sending file as stream "); Send_file_as_stream ( Tcp_identifier ); My_debug_io.Put_line(" File sent as stream "); END IF; My_debug_io.Put_line(" File sent. Closing tcp connection now "); --d DECLARE --DMT -- DUMMY : STRING(1..5) ; -- L : INTEGER ; -- BEGIN -- text_io.put("press enter to continue") ; -- text_io.get_line(DUMMY, L) ; --d END ; Close_tcp_data_link ( Tcp_identifier ); My_debug_io.Put_line (" Tcp connection closed"); Get_reply_from_telnet ( Reply ); My_debug_io.Put_line(" Received reply "); IF Positive_preliminary_reply( Reply ) THEN Output_message_with_new_line(" Page markers not supported"); ELSIF Positive_completion_reply( Reply ) THEN Indicate_command_was_successful( Status ); Output_message_with_new_line(" Transmission successful"); ELSIF Transient_negative_completion_reply( Reply ) THEN Output_message_with_new_line(" Please retry"); ELSIF Permanent_negative_completion_reply( Reply ) THEN Output_message_with_new_line(" Transmisison failed"); ELSE Output_message_with_new_line(" Invalid reply"); END IF; END Send_the_file; PROCEDURE Open_input_file IS BEGIN Get_first_argument_from_argument_list( ARGUMENT, NAME_FIELD ); Convert_argument_to_string( Name_field, File_name, File_name_length ); Output_message (" Opening local inPut file "); Output_message_with_new_line --&MT (File_name(Argument'FIRST .. (File_name(BIT_COUNT_32_TYPE(Argument'FIRST) .. --&MT Argument'FIRST + BIT_COUNT_32_TYPE(Argument'FIRST) + --&MT File_name_length - 1)); BIT_COUNT_32_TYPE(File_name_length) - 1)); Open_input_file --&MT (File_name(Argument'FIRST .. (File_name(BIT_COUNT_32_TYPE(Argument'FIRST) .. --&MT Argument'FIRST + BIT_COUNT_32_TYPE(Argument'FIRST) + --&MT File_name_length - 1)); BIT_COUNT_32_TYPE(File_name_length) - 1)); Get_second_argument_from_argument_list( Argument, Name_field ); Convert_argument_to_string ( Name_field, File_name, File_name_length ); Output_message(" Remote Output filename "); Output_message_with_new_line --&MT (File_name(Argument'FIRST .. (File_name(BIT_COUNT_32_TYPE(Argument'FIRST) .. --&MT Argument'FIRST + BIT_COUNT_32_TYPE(Argument'FIRST) + --&MT File_name_length - 1)); BIT_COUNT_32_TYPE(File_name_length) - 1)); END Open_input_file; PROCEDURE Initiate_file_transfer IS BEGIN My_debug_io.Put_line(" Getting reply to stor command "); --debug Get_reply_from_telnet ( Reply ); My_debug_io.Put_line(" Received reply to stor command "); --debug IF Transient_negative_completion_reply( Reply ) THEN Output_message_with_new_line (" Please retry"); ELSIF Permanent_negative_completion_reply ( Reply ) THEN Output_message_with_new_line (" Invalid request or bad remote filename"); ELSIF Positive_preliminary_reply ( Reply ) THEN My_debug_io.Put_line (" Listening for active open "); Listen_on_current_tcp_port_for_an_active_open( Tcp_identifier ); My_debug_io.Put_line (" Active open received "); Send_the_file; ELSE Output_message_with_new_line(" Invalid reply to STOR request"); END IF; -- end test for initial reply END Initiate_file_transfer; BEGIN -- Start of Send_file_user_to_server Indicate_command_was_not_successful ( Status ); IF Telnet_link_is_open ( User_parameters ) THEN Find_out_if_user_wants_data_echoed_to_screen; Open_input_file; --D My_debug_io.Put_line (" Initializing tcp "); -- Initialize_tcp ( Tcp_identifier ); My_debug_io.Put_line (" Sending stor command "); Send_command_over_telnet ( Transmission_status, Ftp_types.stor_command, Name_field ); IF Transmission_successful( Transmission_status ) THEN Initiate_file_transfer; ELSE -- Else clause for xmit status test Output_message_with_new_line (" Telnet failed; aborting file transfer"); END IF; -- End test for transfer status My_debug_io.Put_line(" Closing inPut file "); Close_input_file; Output_message_with_new_line(" Local inPut file closed"); ELSE -- else clause for telnet status test Output_message_with_new_line (" No telnet link is open; aborting file transfer"); END IF; -- end test for telnet status global_tcp_identifier := tcp_identifier ; EXCEPTION WHEN OTHERS => Output_message_with_new_line (" Unknown error in Send_file_user_to_server"); RAISE; END Send_file_user_to_server; PROCEDURE Accept_file_server_to_user ( Status : OUT Ftp_utilities.command_status_spec; User_parameters : IN Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Name_field : Ftp_types.argument_list; File_name : --&MT STRING( Argument'first..argument'last ); STRING( bit_count_32_type(Argument'first)..bit_count_32_type(argument'last) ); File_name_length: BIT_COUNT_16_TYPE := 0; Transmission_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec; Tcp_identifier : Ftp_tcp.tcp_identifier_spec := global_tcp_identifier ; PROCEDURE Get_the_file IS Current_structure : Argument_list; BEGIN Current_structure := Get_current_structure ( User_parameters ); IF Current_structure ( Current_structure'FIRST ) = Argument_list_unit'('R') THEN My_debug_io.Put_line (" Receiving file as records "); Receive_file_as_records ( Tcp_identifier ); ELSE My_debug_io.Put_line (" Receiving file as stream "); Receive_file_as_stream ( Tcp_identifier ); END IF; My_debug_io.Put_line (" getting reply "); Get_reply_from_telnet ( Reply ); My_debug_io.Put_line (" received reply "); IF Positive_preliminary_reply( Reply ) THEN Output_message_with_new_line(" Page markers not supported"); ELSIF Positive_completion_reply( Reply ) THEN Indicate_command_was_successful( Status ); Output_message_with_new_line(" Transmission successful"); ELSIF Transient_negative_completion_reply( Reply ) THEN Output_message_with_new_line(" Please retry"); ELSIF Permanent_negative_completion_reply( Reply ) THEN Output_message_with_new_line(" Transmisison failed"); ELSE Output_message_with_new_line(" Invalid reply"); END IF; -- end test for secondary reply END Get_the_file; PROCEDURE Create_output_file IS BEGIN Get_second_argument_from_argument_list( Argument, Name_field ); Convert_argument_to_string( Name_field, File_name, File_name_length ); Output_message(" Creating local Output file "); Output_message_with_new_line --&MT ( File_name( Argument'FIRST.. ( File_name( BIT_COUNT_32_TYPE(Argument'FIRST).. --&MT Argument'FIRST + BIT_COUNT_32_TYPE(Argument'FIRST) + --&MT File_name_length - 1)); BIT_COUNT_32_TYPE(File_name_length) - 1)); Open_Output_file --&MT ( File_name( Argument'FIRST.. ( File_name( BIT_COUNT_32_TYPE(Argument'FIRST).. --&MT Argument'FIRST + BIT_COUNT_32_TYPE(Argument'FIRST) + --&MT File_name_length - 1)); BIT_COUNT_32_TYPE(File_name_length) - 1)); My_debug_io.Put_line (" Output file opened "); Get_first_argument_from_argument_list( Argument, Name_field ); Convert_argument_to_string( Name_field, File_name, File_name_length ); Output_message(" Remote inPut filename = "); Output_message_with_new_line --&MT ( File_name( Argument'FIRST.. ( File_name( BIT_COUNT_32_TYPE(Argument'FIRST).. --&MT Argument'FIRST + BIT_COUNT_32_TYPE(Argument'FIRST) + --&MT File_name_length - 1)); BIT_COUNT_32_TYPE(File_name_length) - 1)); END Create_output_file; PROCEDURE Initiate_file_transfer IS BEGIN My_debug_io.Put_line (" getting reply "); Get_reply_from_telnet ( Reply ); My_debug_io.Put_line (" received reply "); IF Transient_negative_completion_reply( Reply ) THEN Output_message_with_new_line(" Please retry command"); ELSIF Permanent_negative_completion_reply ( Reply ) THEN Output_message_with_new_line(" Invalid request"); ELSIF Positive_preliminary_reply ( Reply ) THEN My_debug_io.put_line (" Waiting for tcp open "); Listen_on_current_tcp_port_for_an_active_open ( Tcp_identifier ); My_debug_io.put_line (" Tcp port has been opened "); Output_message_with_new_line(" Starting file transfer"); Get_the_file; ELSE Output_message_with_new_line(" Invalid reply"); END IF; -- end test for initial reply END Initiate_file_transfer; BEGIN Indicate_command_was_not_successful( Status ); IF Telnet_link_is_open ( User_parameters ) THEN Find_out_if_user_wants_data_echoed_to_screen; Create_output_file; -- Initialize_tcp ( Tcp_identifier ); My_debug_io.Put_line (" sending retr command "); Send_command_over_telnet ( Transmission_status, Ftp_types.retr_command, Name_field ); My_debug_io.Put_line (" retr command sent "); IF Transmission_successful( Transmission_status ) THEN Initiate_file_transfer; END IF; -- end test for xmit status My_debug_io.put_line (" Closing output file "); Close_Output_file; -- already done in initiate_file_transfer Output_message_with_new_line(" Local Output file closed"); ELSE Ftp_terminal_driver.Output_message_with_new_line (" No telnet connection open, please CALL remote host first"); END IF; -- end test for telnet status global_tcp_identifier := tcp_identifier ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown error in Accept_file_server_to_user"); RAISE; END Accept_file_server_to_user; BEGIN global_tcp_identifier.connection_status := ftp_tcp.closed ; global_tcp_identifier.local_port_id := 5 ; -- use this local port # for opens ftp_tcp.initialize_tcp(global_tcp_identifier) ; EXCEPTION WHEN OTHERS => My_debug_io.Put_line (" Unknown error in User_xfer_commands"); RAISE; END User_xfer_commands; --:::::::::::::: --ftpusrpi_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01114-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSRPI_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUSRPI AUTHOR : MARK VOLPE -- 5/21/85 10:07 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 2:16 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 2:44 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH Ftp_types, -- Global variables. Reply_types, Ftp_terminal_driver, Ftp_utilities, Ftp_command_utilities, Site_details, Reply_utilities; --&MT THE FOLLOWING LINE WAS ADDED TO GIVE FTPUSRPI BETTER ACCESS TO FTP_TYPES --&MT SO THAT COMPARISONS COULD BE MADE BETWEEN ENUMERATED TYPES : USE FTP_TYPES ; PACKAGE User_pi_commands IS ------------------------------------------------------------------------------- -- -- This package contains the routines to process ftp commands which must be -- transmitted from the user pi to the server pi, and/or directly effect the -- user pi. -- ------------------------------------------------------------------------------- PROCEDURE Send_noop_to_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ); ---------------------------------------------------------------------- -- -- This processes the 'noop' command on the user's side. -- It sends a noop command to the server system via telnet. -- ---------------------------------------------------------------------- PROCEDURE Send_help_to_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure processes the 'help' cmd on the user's side. -- It sends a help command to the server system via telnet. -- ---------------------------------------------------------------------- PROCEDURE Send_quit_to_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ); ---------------------------------------------------------------------- -- -- This procedure is used during the 'quit' command. -- It tells the server system to close the telnet connection. -- No reply is expected other than the close of the telnet link -- ---------------------------------------------------------------------- PROCEDURE Send_user_to_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used during the login process. -- It is used to initiate the login sequence. -- ---------------------------------------------------------------------- PROCEDURE Call_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used to establish a telnet link -- ---------------------------------------------------------------------- PROCEDURE Disconnect_from_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used to close a telnet link -- ---------------------------------------------------------------------- END User_pi_commands; --:::::::::::::: --ftpusrpi.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01115-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSRPI.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUSRPI AUTHOR : MARK VOLPE -- 5/21/85 10:07 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 2:16 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 2:48 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT PACKAGE BODY User_pi_commands IS PROCEDURE Call_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ; Argument : IN Ftp_types.argument_list ) IS BEGIN Ftp_utilities.indicate_command_was_not_successful ( Status ); IF Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_terminal_driver.output_message_with_new_line (" Already a Telnet link open"); ELSE Ftp_utilities.open_telnet_link ( User_parameters, Argument ); IF Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_utilities.indicate_command_was_successful ( Status ); Ftp_terminal_driver.output_message_with_new_line (" Telnet connection established"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Request failed, no connection established"); END IF; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Call_server_pi"); RAISE; END Call_server_pi; PROCEDURE Disconnect_from_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Temp_status : Ftp_utilities.command_status_spec ; BEGIN Ftp_utilities.indicate_command_was_not_successful ( Temp_status ); IF NOT Ftp_utilities.telnet_link_is_open( User_parameters ) THEN Ftp_terminal_driver.output_message_with_new_line (" No telnet connection open"); Ftp_utilities.indicate_command_was_successful ( Temp_status ); ELSE -- Telnet link open, user may or may not be logged in Send_quit_to_server_pi ( Temp_status, User_parameters ); IF Ftp_utilities.command_was_successful ( Temp_status ) THEN Ftp_utilities.indicate_command_was_successful ( Temp_status ); Ftp_terminal_driver.output_message_with_new_line (" Telnet connection closed"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Telnet connection still open"); END IF; END IF; Status := Temp_status ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Disconnect_from_server_pi"); RAISE; END Disconnect_from_server_pi; PROCEDURE Send_pass_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS Xmit_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec; Password : Ftp_types.argument_list := Ftp_types.null_argument; Keyboard_data : Ftp_types.argument_list := Ftp_types.null_argument; Command : Ftp_types.valid_command_spec; Command_status : Ftp_command_utilities.command_status_spec; Temp_status : Ftp_utilities.command_status_spec ; BEGIN -- -- Don't test connection or login status, already done in user -- Ftp_utilities.indicate_command_was_not_successful ( Temp_status ); Ftp_terminal_driver.output_message_with_new_line(" Password required"); Ftp_command_utilities.get_command_from_keyboard ( Command_status, Command, Password ); IF Command /= Ftp_types.pass_command THEN Ftp_terminal_driver.output_message_with_new_line (" Invalid response, password was required"); ELSIF Ftp_command_utilities.argument_list_is_invalid(command_status) THEN Ftp_terminal_driver.output_message_with_new_line (" Invalid password command; please restart with USER"); ELSE Ftp_command_utilities.send_command_over_telnet ( Xmit_status, Ftp_types.pass_command, Password ); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet( Reply ); IF Reply_types.positive_completion_reply ( Reply ) THEN Ftp_utilities.indicate_command_was_successful (Temp_status); ELSIF Reply_types.positive_intermediate_reply( Reply ) THEN Ftp_terminal_driver.output_message_with_new_line (" Accounting not implemented; please restart with USER"); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry starting with USER"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Password failed at remote host;" & " please retry starting with USER"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply to password;" & " please retry starting with USER"); END IF; END IF; END IF; IF Ftp_utilities.command_was_successful ( Temp_status ) THEN Ftp_utilities.indicate_user_is_logged_in( User_parameters ); ELSE Ftp_utilities.indicate_user_is_logged_out( User_parameters); END IF; Status := Temp_status ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_pass_to_server_pi"); RAISE; END Send_pass_to_server_pi ; PROCEDURE Send_user_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Xmit_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec; Username : Ftp_types.argument_list := Ftp_types.null_argument; BEGIN Ftp_utilities.indicate_command_was_not_successful ( Status ); IF Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_command_utilities.get_first_argument_from_argument_list ( Argument, Username ); Ftp_command_utilities.send_command_over_telnet ( Xmit_status , Ftp_types.user_command, Username ); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet( Reply ); IF Reply_types.positive_completion_reply ( Reply ) THEN Ftp_utilities.indicate_user_is_logged_in ( User_parameters ); Ftp_utilities.indicate_command_was_successful ( Status ); ELSIF Reply_types.positive_intermediate_reply( Reply ) THEN -- Return status set according to return status of -- send pass Send_pass_to_server_pi ( Status, User_parameters ); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry the USER command"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Command failed at remote host;" & " user is not logged in"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply to command; please retry"); END IF; -- End reply tests ELSE Ftp_terminal_driver.output_message_with_new_line (" User not logged in; TCp failed"); END IF; -- END TEST FOR XMIT STATUS ELSE Ftp_terminal_driver.output_message_with_new_line (" Please CALL the remote host first"); END IF; -- End test to see if telnet link open EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_user_to_server_pi"); RAISE; END Send_user_to_server_pi ; PROCEDURE Send_noop_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS Reply : Reply_types.reply_code_spec; Xmit_status : Ftp_command_utilities.transmission_status_spec; BEGIN Ftp_utilities.indicate_command_was_not_successful ( Status ); IF NOT Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_terminal_driver.output_message_with_new_line (" No telnet connection, " & " please CALL remote_host first"); ELSE Ftp_command_utilities.send_command_over_telnet ( Xmit_status , Ftp_types.noop_command, Ftp_types.null_argument ); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet( Reply ); IF Reply_types.positive_completion_reply ( Reply ) THEN Ftp_utilities.indicate_command_was_successful (status); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Command failed at remote host"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply, please retry"); END IF; END IF; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_noop_to_server_pi"); RAISE; END Send_noop_to_server_pi; PROCEDURE Send_help_to_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Xmit_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec; BEGIN Ftp_utilities.indicate_command_was_not_successful (status); IF NOT Ftp_utilities.telnet_link_is_open( User_parameters ) THEN Ftp_terminal_driver.output_message_with_new_line (" Local help not yet implemented"); Ftp_terminal_driver.output_message_with_new_line (" Please call a remote host"); ELSE Ftp_command_utilities.send_command_over_telnet ( Xmit_status, Ftp_types.help_command, Argument ); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet ( Reply ); IF Reply_types.positive_completion_reply( Reply ) THEN Ftp_utilities.indicate_command_was_successful ( Status ); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Command failed at remote host"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply, please retry"); END IF; END IF; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_help_to_server_pi"); RAISE; END Send_help_to_server_pi ; PROCEDURE Send_quit_to_server_pi ( Status : out Ftp_utilities.command_status_spec; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS Xmit_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec; Argument : Ftp_types.argument_list := Ftp_types.null_argument; BEGIN Ftp_utilities.indicate_command_was_not_successful( Status ); IF NOT Ftp_utilities.telnet_link_is_open( User_parameters ) THEN Ftp_terminal_driver.output_message_with_new_line (" No telnet connection open"); ELSE Ftp_command_utilities.send_command_over_telnet ( Xmit_status,ftp_types.quit_command,argument); IF Ftp_command_utilities.transmission_successful ( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet ( Reply ); IF Reply_types.positive_completion_reply(reply) THEN Ftp_utilities.indicate_user_is_logged_out(user_parameters); Ftp_utilities.indicate_telnet_link_closed(user_parameters); Ftp_utilities.indicate_command_was_successful (status); ELSE Ftp_terminal_driver.output_message_with_new_line (" User still logged"); END IF; END IF; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_quit_to_server_pi"); RAISE; END SEND_QUIT_TO_SERVER_PI; BEGIN NULL; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in User_pi_commands"); RAISE; END User_pi_commands; --:::::::::::::: --ftpusrdtp_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01112-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSRDTP_.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUSRDTP AUTHOR : MARK VOLPE -- 5/21/85 10:39 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 2:29 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 2:58 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING DEC ADA : --&MT PRAGMA SOURCE_INFO ( ON ); WITH My_debug_io, Ftp_types, Reply_types, Ftp_terminal_driver, Ftp_command_utilities, Site_details, Ftp_utilities, Reply_utilities; PACKAGE User_dtp_commands IS ---------------------------------------------------------------------- -- -- This package conatins procedures which effect the way files -- are sent between PI's. -- ---------------------------------------------------------------------- PROCEDURE Send_stru_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used during the 'stru' command. -- It sends the new structure to the server system. -- ---------------------------------------------------------------------- PROCEDURE Send_type_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used during the 'type' command. -- It sends the new type to the server system. -- ---------------------------------------------------------------------- PROCEDURE Send_mode_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used during the 'mode' command. -- It sends the new mode to the server system. -- ---------------------------------------------------------------------- PROCEDURE Send_port_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ); ---------------------------------------------------------------------- -- -- This procedure is used during the 'port' command. -- It sends the new transmit port to the server system. -- ---------------------------------------------------------------------- END User_dtp_commands; --:::::::::::::: --ftpusrdtp.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01113-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSRDTP.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : FTPUSRDTP AUTHOR : MARK VOLPE -- 5/21/85 10:39 AM : REVISED FOR USE WITH DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/31/85 2:29 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/31/85 3:04 PM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT --&MT THE FOLLOWING LINE WAS ADDED TO GIVE FTPUSRDTP.ADA ACCESS TO TEXT_IO : WITH TEXT_IO ; PACKAGE BODY User_dtp_commands IS --&MT SUBTYPE BIT_COUNT_32_TYPE IS LONG_INTEGER; SUBTYPE BIT_COUNT_32_TYPE IS INTEGER; --&MT SUBTYPE BIT_COUNT_16_TYPE IS INTEGER; SUBTYPE BIT_COUNT_16_TYPE IS SHORT_INTEGER; --&MT THE FOLLOWING LINES SHOULD BE DELETED WHEN USING TELESOFT : PACKAGE LONG_INT IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_32_TYPE); PACKAGE INT_IO IS NEW TEXT_IO.INTEGER_IO(BIT_COUNT_16_TYPE); PROCEDURE Change_our_port ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Port_id : Ftp_types.argument_list; Strng : --&MT STRING( Argument'first..argument'last ); STRING( bit_count_32_type(Argument'first)..bit_count_32_type(argument'last) ); Strng_length : BIT_COUNT_16_TYPE; Temp_status : Ftp_utilities.command_status_spec ; BEGIN Ftp_utilities.change_port ( Temp_status, User_parameters, Argument ); IF NOT Ftp_utilities.command_was_successful ( Temp_status ) THEN Ftp_terminal_driver.output_message_with_new_line (" Invalid port specified"); END IF; Port_id := Ftp_utilities.get_current_port ( User_parameters ); Ftp_types.convert_argument_to_string ( Port_id, Strng, Strng_length ); Ftp_terminal_driver.output_message (" New port is: "); Ftp_terminal_driver.output_message_with_new_line ( Strng( Strng'first..strng'first + --&MT Strng_length - 1) ); bit_count_32_type(Strng_length) - 1) ); STATUS := Temp_status ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Change_our_port"); RAISE; END Change_our_port; PROCEDURE Send_port_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Reply : Reply_types.reply_code_spec; XMIT_STATUS : Ftp_command_utilities.transmission_status_spec; BEGIN Ftp_utilities.indicate_command_was_not_successful( Status ); IF Site_details.specified_host_is_this_host( Argument ) THEN Change_our_port ( Status, User_parameters, Argument ); ELSIF NOT Ftp_utilities.telnet_link_is_open( User_parameters ) THEN Ftp_terminal_driver.output_message_with_new_line (" No telnet connection, " & " please CALL remote_host first"); ELSE Ftp_command_utilities.send_command_over_telnet ( Xmit_status, Ftp_types.port_command, Argument ); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet( Reply ); IF Reply_types.positive_completion_reply ( Reply ) THEN Ftp_utilities.indicate_command_was_successful( Status); Ftp_terminal_driver.output_message_with_new_line (" Remote port changed"); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry"); ELSIF Reply_types.permanent_negative_completion_reply( Reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Command failed at remote host"); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply, please retry"); END IF; END IF; END IF; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_port_to_server_pi"); RAISE; END Send_port_to_server_pi; PROCEDURE Send_stru_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Xmit_status : Ftp_command_utilities.transmission_status_spec; Reply : Reply_types.reply_code_spec ; Current_structure : Ftp_types.argument_list := Ftp_utilities.get_current_structure( User_parameters ); Temp_status : Ftp_utilities.command_status_spec ; BEGIN Ftp_utilities.change_file_structure ( Temp_status, User_parameters, Argument ); IF Ftp_utilities.command_was_successful ( Temp_status ) THEN IF Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_command_utilities.send_command_over_telnet ( Xmit_status,ftp_types.stru_command,argument); -- -- Make sure the command got there. -- IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Ftp_utilities.indicate_command_was_not_successful(Temp_status); Reply_utilities.get_reply_from_telnet( Reply ); IF Reply_types.positive_completion_reply (reply) THEN Ftp_utilities.indicate_command_was_successful(Temp_status); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Structure not supported at remote host."); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply, please retry"); END IF; END IF; END IF; ELSE Ftp_terminal_driver.output_message_with_new_line (" That structure is not supported at this host"); END IF; IF NOT Ftp_utilities.command_was_successful ( Temp_status ) THEN Ftp_utilities.change_file_structure ( Temp_status, User_parameters, Current_structure ); END IF; Current_structure := Ftp_utilities.get_current_structure ( User_parameters ); Ftp_terminal_driver.output_message (" Structure is "); Ftp_terminal_driver.output_message ( CHARACTER'( Current_structure( Current_structure'first ))); Ftp_terminal_driver.new_line; Status := Temp_status ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_stru_to_server_pi"); RAISE; END Send_stru_to_server_pi ; PROCEDURE Send_type_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Reply : Reply_types.reply_code_spec; Xmit_status : Ftp_command_utilities.transmission_status_spec; Current_type_and_carriage_control : Ftp_types.argument_list := Ftp_utilities.get_current_type ( User_parameters ); Temp_argument : Ftp_types.argument_list; Temp_status : Ftp_utilities.command_status_spec ; BEGIN Ftp_utilities.change_file_type ( Temp_status, User_parameters, Argument ); IF Ftp_utilities.command_was_successful ( Temp_status ) THEN IF Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_command_utilities.send_command_over_telnet ( Xmit_status, Ftp_types.type_command, Argument); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet( Reply ); Ftp_utilities.indicate_command_was_not_successful ( Temp_status ); IF Reply_types.positive_completion_reply( Reply) THEN Ftp_utilities.indicate_command_was_successful(Temp_status); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Type and/or carriage control " & "not supported at remote host."); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply, please retry"); END IF; END IF; END IF; ELSE Ftp_terminal_driver.output_message_with_new_line (" That type and/or carriage control " & "is not supported at this host"); END IF; IF NOT Ftp_utilities.command_was_successful ( Temp_status ) THEN Ftp_utilities.change_file_type (Temp_status, User_parameters, Current_type_and_carriage_control); END IF; Current_type_and_carriage_control := Ftp_utilities.get_current_type( User_parameters ); Ftp_command_utilities.get_first_argument_from_argument_list ( Current_type_and_carriage_control, Temp_argument ); Ftp_terminal_driver.output_message (" Type is "); Ftp_terminal_driver.output_message ( CHARACTER'(TEMP_ARGUMENT(TEMP_ARGUMENT'FIRST))); Ftp_terminal_driver.new_line; Ftp_command_utilities.get_second_argument_from_argument_list ( Current_type_and_carriage_control, Temp_argument ); Ftp_terminal_driver.output_message (" Carriage control is "); Ftp_terminal_driver.output_message ( CHARACTER'( Temp_argument( Temp_argument'first))); Ftp_terminal_driver.new_line; STATUS := Temp_status ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_type_to_server_pi"); RAISE; END Send_type_to_server_pi ; PROCEDURE Send_mode_to_server_pi ( Status : out Ftp_utilities.command_status_spec ; User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec; Argument : IN Ftp_types.argument_list ) IS Reply : Reply_types.reply_code_spec ; Xmit_status : Ftp_command_utilities.transmission_status_spec; Current_mode : Ftp_types.argument_list := Ftp_utilities.get_current_mode ( User_parameters ); Temp_status : Ftp_utilities.command_status_spec ; BEGIN Ftp_utilities.change_file_mode ( Temp_status, User_parameters, Argument ); IF Ftp_utilities.command_was_successful ( Temp_status ) THEN IF Ftp_utilities.telnet_link_is_open ( User_parameters ) THEN Ftp_utilities.indicate_command_was_not_successful ( Temp_status ); Ftp_command_utilities.send_command_over_telnet ( Xmit_status,ftp_types.mode_command,argument); IF Ftp_command_utilities.transmission_successful( Xmit_status ) THEN Reply_utilities.get_reply_from_telnet( Reply ); IF Reply_types.positive_completion_reply (reply) THEN Ftp_utilities.indicate_command_was_successful(Temp_status); ELSIF Reply_types.transient_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Please retry"); ELSIF Reply_types.permanent_negative_completion_reply(reply) THEN Ftp_terminal_driver.output_message_with_new_line (" Mode not supported at remote host."); ELSE Ftp_terminal_driver.output_message_with_new_line (" Invalid reply, please retry"); END IF; END IF; END IF; ELSE Ftp_terminal_driver.output_message_with_new_line (" That mode is not supported at this host"); END IF; IF NOT Ftp_utilities.command_was_successful ( Temp_status ) THEN Ftp_utilities.change_file_mode ( Temp_status, User_parameters, Current_mode ); END IF; Current_mode := Ftp_utilities.get_current_mode ( User_parameters ); Ftp_terminal_driver.output_message (" Mode is "); Ftp_terminal_driver.output_message ( CHARACTER'( Current_mode(current_mode'first))); Ftp_terminal_driver.new_line; Status := Temp_status ; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in Send_mode_to_server_pi"); RAISE; END Send_mode_to_server_pi ; BEGIN NULL; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in User_dtp_commands"); RAISE; END User_dtp_commands; --:::::::::::::: --ftpuser.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00005-200 80-01111-100(-) -- E-Systems, Inc. August 07, 1985 -- -- FTPUSER.ADA Author : Mark Volpe -- ----------------------------------------------------------------------- -- FILE : Ftpuser AUTHOR : MARK VOLPE -- REVISED FOR USE WITH DEC COMPILER ON : 5/21/85 11:25 AM -- REVISIONS MARKED WITH &MT -- 6/24/85 4:45 PM : converted SERVER_TELNET into a task, -- added code appended with --&KJW --&MT PRAGMA SOURCE_INFO ( ON ); WITH Server_telnet_package, --&KJW Ftp_types, -- GLOBAL TYPES AND VARIABLES Ftp_command_utilities, -- GET COMMAND FROM KEYBOARD Ftp_terminal_driver, -- FOR OUTPUT TO THE TERMINAL User_pi_commands, -- COMMANDS TO USER PI User_dtp_commands, -- User_xfer_commands, -- COMMANDS TO XFER FILES Ftp_utilities; -- USE User_xfer_commands, User_pi_commands, User_dtp_commands; PROCEDURE User_ftp IS ---------------------------------------------------------------------- -- -- This procedure is the upper level of FTP on the user side. -- It is responsible for interfacing between the user and the remote -- system. -- -- The command is accepted from the user via the nvt keyboard. -- This command is then verified and converted to an enumerated type. -- A command handler is called based on this enumerated type. -- ---------------------------------------------------------------------- User_parameters : Ftp_utilities.ftp_parameters_spec; TelNet_Server : Server_telnet_package.TelNet_Controller; TASK Process_User_Command IS --&KJW PRAGMA Priority(6); --&KJW END Process_User_Command; --&KJW TASK BODY Process_User_Command IS --&KJW --PROCEDURE Process_user_command -- ( User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS -- N O T I C E :: What was once parameter "server_parameters" --&KJW -- is now global object "server_parameters" --&KJW ----------------------------------------------------------------- -- -- This procedure is the driver for ftp on the user side. -- It gets the command from telnet then calls the appropriate command -- handler. -- ----------------------------------------------------------------- Command : Ftp_types.valid_command_spec; Argument : Ftp_types.argument_list; User_command_status : Ftp_utilities.command_status_spec; Command_status : Ftp_command_utilities.command_status_spec; BEGIN LOOP Ftp_command_utilities.get_command_from_keyboard ( Command_status, Command, Argument ); IF Ftp_command_utilities.argument_list_is_invalid( Command_status ) THEN Ftp_terminal_driver.output_message_with_new_line (" Invalid command "); ELSE CASE FTP_TYPES.VALID_COMMAND_SPEC'(COMMAND) IS WHEN Ftp_types.call_command => Call_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.clos_command => Disconnect_from_server_pi ( User_command_status, User_parameters, Argument); WHEN Ftp_types.exit_command => Disconnect_from_server_pi ( User_command_status, User_parameters, Argument); IF Ftp_utilities.command_was_successful ( User_command_status ) THEN EXIT; END IF; WHEN Ftp_types.quit_command => Send_quit_to_server_pi ( User_command_status, User_parameters ); WHEN Ftp_types.help_command => Send_help_to_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.user_command => Send_user_to_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.pass_command => Ftp_terminal_driver.output_message_with_new_line (" Password not valid in this context"); WHEN Ftp_types.noop_command => Send_noop_to_server_pi ( User_command_status, User_parameters ); WHEN Ftp_types.stru_command => Send_stru_to_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.type_command => Send_type_to_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.mode_command => Send_mode_to_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.port_command => Send_port_to_server_pi ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.stor_command => User_xfer_commands.send_file_user_to_server ( User_command_status, User_parameters, Argument ); WHEN Ftp_types.retr_command => User_xfer_commands.accept_file_server_to_user ( User_command_status, User_parameters, Argument ); WHEN Others => NULL; END CASE; END IF; END LOOP; EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exeception in Process_User_Command"); RAISE; END Process_user_command ; PROCEDURE User_exception_abort ( User_parameters : IN OUT Ftp_utilities.ftp_parameters_spec ) IS ---------------------------------------------------------------------- -- -- This procedure issues commands over telnet that will cause a server -- system to be logged out. Any data xfers in progress will be -- iqnored. -- ---------------------------------------------------------------------- Return_status : FTP_UTILITIES.command_status_spec; BEGIN Ftp_terminal_driver.new_line; Ftp_terminal_driver.output_message_with_new_line (" Exception during command processing "); Ftp_terminal_driver.output_message_with_new_line (" FTP process aborted"); User_pi_commands.send_quit_to_server_pi ( return_status, User_parameters ); -- TELL SERVER TO SHUT DOWN EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in User_Exception_Abort"); END User_exception_abort; BEGIN -- Process_user_command( User_parameters ); --&KJW TelNet_Server.Connection_Assignments(-1,0,0); --&KJW EXCEPTION WHEN OTHERS => Ftp_terminal_driver.output_message_with_new_line (" Unknown exception in User_Ftp"); User_exception_abort( User_parameters ); END User_ftp;