Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/defdata/smtpwict.src

Text File | 1988-05-03 | 75.2 KB | 2,240 lines

--::::::::::::::
--cycle.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01217-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         cycle.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
with subnet_controller_task ;    use subnet_controller_task ;
with internet_protocol_control_and_send_processing ;
use internet_protocol_control_and_send_processing ;
with tcp_controller_task ;    use tcp_controller_task ;
package  cycle  is
  procedure tcp_ip_subnet ;
end cycle ;
package body  cycle  is
  procedure tcp_ip_subnet is
  begin
    -- first, go for data coming into the node from Ethernet
    subnet_controller ;
    ip_controller ;
    subnet_controller ;
    tcp_controller ;
    subnet_controller ;
  end tcp_ip_subnet ;
end cycle ;
--::::::::::::::
--sconn.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01218-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sconn.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_connections is
--
-- This package contains support for establishing the connection
--  between the ssmtp and a usmtp.
--
procedure establish_transport_connection ;
--
-- This procedure sets up the transport connection between the
-- ssmtp and a usmtp. It waits for a usmtp to call it, performs
-- any handshaking required, and sends the ssmtp greeting reply.
--
procedure establish_sender ;
--
-- this procedure gets the helo command from the usmtp and saves the
-- usmtp host string. Currently does not verify the host name string.
--
end ssmtp_connections ;
with ssmtp_transport ;    use ssmtp_transport ;
with ssmtp_globals ;      use ssmtp_globals ;
with ssmtp_replies ;      use ssmtp_replies ;
with text_io ;            use text_io ;
with ssmtp_logger ;       use ssmtp_logger ;
package body ssmtp_connections is
--
--   Implementation for :  Labtek WICAT
--                         TeleSoft/Ada (Version 1.3)
--                         tcp transport service
--
procedure establish_transport_connection is
done : boolean := false;    --&KJW 16-jul85
begin
if not transport_connection_open then
  send_passive_open ;
  wait_for_open ;
  end if ;
--&KJW 16-jul-85 loop
while NOT done loop    --&KJW 16-jul85
  begin
    send_ready_message ;
    reset_receive_buffers ;
    get_command ;
    if command = "helo" then
      source_host := command_parms ; -- save the "from" address as is
      send_helo_ok ;
      --&KJW 16-jul-85 exit ;
      done := true;    --&KJW 16-jul85
    else
        bad_command ;
    end if ;
  exception
    when ssmtp_reset =>
      put_line("RSET received") ;
    when others =>
      error_log ("Exception in ssmtp connection") ;
      raise ;
  end ;
end loop ;
end ;
procedure establish_sender is
begin
  get_command ;
  if command = "mail" then
    source_name := command_parms ;
    send_mail_ok ;
  else
    bad_command ;
  end if ;
  exception
    when ssmtp_reset =>
      put_line("RSET received") ;
    when others =>
      error_log ("Exception in establish sender") ;
      raise ;
  end establish_sender ;
end ssmtp_connections ;
--::::::::::::::
--sdel.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01219-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sdel.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_deliver is
procedure deliver_mail ;
end ssmtp_deliver ;
with ssmtp_globals ;   use ssmtp_globals ;
with ssmtp_logger ;    use ssmtp_logger ;
with ssmtp_replies ;   use ssmtp_replies ;
with text_io ;         use text_io ;
with system;           use system ;
package body ssmtp_deliver is
procedure copy_mail(user_name : user_name_type; ok : out boolean ) is
--&KJW 16-jul-85 smtp_mail : file_type ;
begin
  --&KJW 16-jul-85 put("deliver mail to...") ;
  text_io.put("deliver mail to...") ;    --&KJW 16-jul-85
  --&KJW 16-jul-85 put_line(user_name) ;
  text_io.put_line(user_name) ;        --&KJW 16-jul-85
  ok := true ;
  --&KJW 16-jul-85 create(smtp_mail,out_file,"smtp_mail.txt") ;
  for i in 1..message_length loop
    --&KJW 16-jul-85 put_line(smtp_mail,message(i).message_line(1..message(i).line_length)) ;
    --&KJW 16-jul-85 put_line(message(i).message_line(1..message(i).line_length)) ;
    text_io.put_line(message(i).message_line(1..message(i).line_length)) ;--&KJW 16-jul-85
  end loop ;
  --&KJW 16-jul-85 close(smtp_mail) ;
  exception
    when others =>
      error_log("Exception in copy mail");
  end ;
procedure deliver_mail is
all_ok, delivered_ok : boolean := true ;
--&KJW 16-jul-85 rcpt_file : file_type ;
begin
  --&KJW 16-jul-85 create(rcpt_file,out_file,"rcpt_list.txt") ;
  for i in 1..number_of_rcpt loop
    --&KJW 16-jul-85 put_line(rcpt_file,rcpt_list(i)) ;
    copy_mail(rcpt_list(i),delivered_ok);
    all_ok := delivered_ok and all_ok ;
  end loop ;
  if all_ok then
    send_completed_ok ;
  else
    send_completed_not_ok ;
  end if ;
  exception
    when others =>
      error_log("Exception in copy mail");
end ;
end ssmtp_deliver ;
--::::::::::::::
--sglobs.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01220-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sglobs.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_globals is
-- here are the conditions which interrupt
--  normal flow of control:
sudden_connection_close : exception ;
 -- connection closed or connection aborted
transport_error         : exception ;
 -- unexpected message from transport
ssmtp_reset             : exception ;
 -- reset command received
ssmtp_quit              : exception ;
 -- quit command received
--&KJW 21-jul-85 transport_connection_open : boolean ;
transport_connection_open : boolean := false ;  --&KJW 21-jul-85
 -- state of the transport connection
--
-- this is to support the list of local receivers
-- smtp_rcpt creates this list
-- smtp_deliver uses it
--
subtype user_name_type is string (1..80) ;
subtype host_name_type is string (1..80) ;
max_rcpt           : constant integer := 80 ;
rcpt_list          : array (1..max_rcpt) of user_name_type ;
number_of_rcpt     : integer range 0..max_rcpt ;
source_host        : host_name_type ;
source_host_length : integer range 0..80 ;
source_name        : user_name_type ;
source_name_length : integer range 0..80 ;
--
-- used to parse the smtp commands
--
max_command_length : constant integer := 80 ;
command            : string (1..4) ;
  -- 4 letter smtp command, lower case
command_parms      : string (1..max_command_length) ;
  -- the rest of the received command
parm_length        : integer range 0..max_command_length ;
--
-- where the mail message is saved
--
type lines is record
  message_line : string(1..512) ;
  line_length  : integer ;
  end record ;
max_message_length : constant integer := 2048 ;
message            : array (1..max_message_length) of lines ;
message_length     : integer ;
procedure reset_receive_buffers ;
  -- prepare to receive a new message
end ssmtp_globals ;
package body ssmtp_globals is
procedure reset_receive_buffers is
  begin
  number_of_rcpt := 0 ;
  message_length := 0 ;
end reset_receive_buffers ;
end ssmtp_globals ;
--::::::::::::::
--slog.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01221-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         slog.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_logger is
procedure error_log (msg : string) ;
end ssmtp_logger ;
-- debug version
with text_io ; use text_io ;
package body ssmtp_logger is
procedure error_log (msg : string) is
begin
--- may also record connection info, such as usmtp host, usmtp name, etc
put_line(msg) ;
end error_log ;
end ssmtp_logger ;
--::::::::::::::
--srcpt.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01222-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         srcpt.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_rcpt is
  procedure expect_rcpt_list ;
end ssmtp_rcpt ;
with ssmtp_transport ;    use ssmtp_transport ;
with ssmtp_globals ;      use ssmtp_globals ;
with ssmtp_replies ;      use ssmtp_replies ;
with text_io ;            use text_io ;
with ssmtp_logger ;       use ssmtp_logger ;
package body ssmtp_rcpt is
-- this table is system dependent, not really the best method
done : boolean := false;    --KJW 16-jul-85
blank_name : user_name_type ;    --KJW 16-jul-85
max_users : integer := 100 ;
user_name_table : array (1..max_users) of user_name_type ;
number_of_users : integer ;
procedure lookup_user_name(name       : in  user_name_type ;
                           user_local : out boolean) is
--- look up user in list
--- could make system call if available
begin
--&KJW 23-jul-85 put("looking up ") ;
--&KJW 23-jul-85 put_line(name) ;
user_local := false ;
for i in 1..number_of_users loop
  if user_name_table(i) = name then
    user_local := true ;
    exit ;
  end if ;
end loop ;
exception
when others =>
  error_log("exception in lookup_user_name") ;
  raise ;
end lookup_user_name ;
procedure parse_user_name(user_local : out boolean;
                          user_name  : out user_name_type) is
ptr : integer := 0 ;
name : user_name_type := blank_name ;    --&KJW 16-jul-85
begin
user_name := blank_name ;        --&KJW 16-jul-85
user_local := false ;
for i in 1..parm_length loop
  if command_parms(i) /= ' ' then
    ptr := i ;
    exit ;
  end if ;
end loop ;
if ((ptr /= 0) and (ptr <= parm_length+3)) and then
    command_parms(ptr..ptr+2) = "to:" then
  for i in 1..(parm_length-(ptr+3)) loop
    name(i) := command_parms(i+ptr+3) ;
  end loop ;
  lookup_user_name(name,user_local) ;
  user_name := name ;
else
  put("bad format rcpt: ") ;
  put_line(command_parms) ;
end if ;
exception
when others =>
  error_log("exception in parse_user_name") ;
  raise ;
end parse_user_name ;
procedure expect_rcpt_list is
  user_local : boolean ;
  user_name  : user_name_type ;
  begin
  loop
    get_command ;
    if command = "rcpt" then
      parse_user_name(user_local,user_name) ;
      if not user_local then
        send_rcpt_not_ok  ;
      else
        if number_of_rcpt < max_rcpt then
          number_of_rcpt := number_of_rcpt + 1 ;
          --&KJW 16-jul-85 rcpt_list(number_of_rcpt) := (others => ' ') ;
          rcpt_list(number_of_rcpt) := blank_name ;    --&KJW 16-jul-85
          rcpt_list(number_of_rcpt) := user_name ;
          send_rcpt_ok ;
        else
          send_no_room ;
        end if ;
      end if ;
    elsif command = "data" then
      exit ;
    else
      bad_command ;
    end if ;
    end loop ;
  exception
    when ssmtp_reset =>
      put_line("Reset in establish_rcpt");
      raise ssmtp_reset ;
    when ssmtp_quit =>
      put_line("Reset in establish_rcpt");
      raise ssmtp_quit ;
    when others =>
      error_log("exception in establish_rcpt");
      raise ;
end expect_rcpt_list ;
begin
--&KJW 11-jul-85 user_name_table(1)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(1)(1..7) := "higgins" ;
--&KJW 11-jul-85 user_name_table(2)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(2)(1..6) := "thomas" ;
--&KJW 11-jul-85 user_name_table(3)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(3)(1..5) := "baldo" ;
--&KJW 11-jul-85 user_name_table(3)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(3)(1..7) := "noscada" ;
--&KJW 11-jul-85 number_of_users := 4 ;
-- Read user names into user_name_table from file "usernames.lcl".
-- Each installation can configure allowable user identifiers via this file.
-- If the open for the file fails, then it is either in use (i.e. being editted)
-- or does not exist.  This version of the SMTP server cannot continue if there
-- are no local users since it does not forward mail to another node.
for char in 1..80 loop        --&KJW 16-jul-85
  blank_name(char) := ' ';    --&KJW 16-jul-85
end loop;            --&KJW 16-jul-85
while not done            --&KJW 16-jul-85
loop
  declare
    name_file : file_type ;
    last,index : natural ;
  begin
    open(name_file,in_file,"usernames.lcl") ;
    number_of_users := 0 ;
    while not end_of_file(name_file) loop
      index := number_of_users + 1;
      get_line (name_file, user_name_table(index), last) ;
      -- user names can be in any form; but they must NOT be preceeded by any
      -- "white space" (this implementation won't look for it or discard it).
      -- the length of a user name must NOT exceed the space reserved for it in
      -- the user_name_table (regardless of the unused space in other names).
      -- comments in the name table are introduced as Ada-style comments; how-
      -- ever, the two hyphens must be the first two characters in the line.
      if user_name_table(index)(1..2) /= "--" then
        --KJW 16-jul-85 user_name_table(index)(last+1 .. user_name_table(index)'Last)
        --KJW 16-jul-85     := (others => ' ') ;
        for char in last+1..80 loop        --KJW 16-jul-85
          user_name_table(index)(char) := ' ';    --KJW 16-jul-85
        end loop;                --KJW 16-jul-85
        number_of_users := index ;
      end if ;
      exit when number_of_users >= max_users ;
    end loop ;
    close(name_file) ;
    --&KJW 16-jul-85 exit ;
    done := true;        --&KJW 16-jul-85
  exception
    when status_error =>    -- file is open; try again later
      --&KJW 16-jul-85 delay 30.0;
      put_line("status_error in package body ssmtp_rcpt elaboration.") ;        --&KJW 16-jul-85
      raise;            --&KJW 16-jul-85
    when name_error =>        -- file does not exist
      put_line("could not find file 'usernames.lcl'" &
               " in package body ssmtp_rcpt") ;
      raise ;
    when others =>        -- ???
      put_line("unknown exception in package body ssmtp_rcpt elaboration.") ;
      close(name_file) ;    -- just in case it was open
      raise;
  end ;
end loop ;
end ssmtp_rcpt;
--::::::::::::::
--sreps.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01223-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sreps.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_replies is
procedure send_ready_message ;
procedure send_helo_ok ;
procedure send_mail_ok ;
procedure send_rcpt_ok ;
procedure send_rcpt_not_ok ;
procedure send_no_room ;
procedure send_data_ok ;
procedure send_completed_ok ;
procedure send_completed_not_ok ;
procedure send_quit_ok ;
procedure bad_command ;
end ssmtp_replies ;
with ssmtp_transport ; use ssmtp_transport ;
with text_io ;         use text_io ;
with ssmtp_logger ;    use ssmtp_logger ;
with ssmtp_globals ;   use ssmtp_globals ;
package body ssmtp_replies is
procedure send_ready_message is
  begin
  send_string("220  SMTP mail service ready") ;
  exception
    when others =>
      error_log ("Exception in send_ready_message") ;
  end send_ready_message ;
procedure send_helo_ok is
  begin
  send_string("250 Helo ok") ;
  exception
    when others =>
    error_log  ("Exception in send_helo_ok") ;
  end send_helo_ok ;
procedure send_mail_ok is
  begin
  send_string("250 mail ok") ;
  exception
    when others =>
    error_log  ("Exception in send_mail_ok") ;
  end send_mail_ok ;
procedure send_rcpt_ok is
  begin
  send_string("250 rcpt ok") ;
  exception
    when others =>
      error_log  ("Exception in send_rcpt_ok") ;
  end send_rcpt_ok ;
procedure send_rcpt_not_ok is
  begin
  send_string("550 User not local, cannot forward") ;
  exception
    when others =>
      error_log  ("Exception in send_rcpt_not_ok") ;
  end send_rcpt_not_ok ;
procedure send_no_room is
  begin
  send_string("501 out of resources") ;
  error_log("Ran out of resources") ;
  exception
    when others =>
      error_log  ("Exception in send_no_room ") ;
  end send_no_room ;
procedure send_data_ok is
  begin
  send_string("354 begin data... ") ;
  exception
    when others =>
      error_log  ("Exception in send_data_ok") ;
  end send_data_ok ;
procedure send_completed_ok is
  begin
  send_string("250 mail sent") ;
  exception
    when others =>
      error_log  ("Exception in send_completed_ok") ;
  end send_completed_ok ;
procedure send_completed_not_ok is
  begin
  send_string("250 mail not sent to some recipients ") ;
  exception
    when others =>
      error_log  ("Exception in send_completed_not_ok") ;
  end send_completed_not_ok ;
procedure send_quit_ok is
  begin
  send_string("221 SMTP closing connection") ;
  exception
    when others =>
      error_log  ("Exception in send_quit_ok") ;
  end send_quit_ok ;
procedure bad_command is
  begin
  if command = "rset" then
    raise ssmtp_reset ;
  elsif command = "quit" then
    raise ssmtp_quit ;
  else
    send_string("451 Unexpected or unimplemented command") ;
  end if ;
  exception
    when ssmtp_reset | ssmtp_quit =>
      raise ;
    when others =>
      error_log ("Exception in bad_command") ;
      raise ;
  end bad_command ;

end ssmtp_replies ;
--::::::::::::::
--ssmtp.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01224-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ssmtp.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
with real_time_clock_and_date;
use real_time_clock_and_date;
with text_io;            use text_io ;
with ssmtp_globals ;     use ssmtp_globals ;
with ssmtp_replies ;     use ssmtp_replies ;
with ssmtp_connections ; use ssmtp_connections ;
with ssmtp_transport ;   use ssmtp_transport ;
with ssmtp_rcpt ;        use ssmtp_rcpt ;
with ssmtp_text ;        use ssmtp_text ;
with ssmtp_deliver ;     use ssmtp_deliver ;
with ssmtp_logger ;      use ssmtp_logger ;
with buffer_data ;       use buffer_data ;
procedure ssmtp is
begin
  start_local_clock;
  buffer_data.init ;
  loop
    begin
    establish_transport_connection ;
    establish_sender ;
    loop
      begin
      reset_receive_buffers ;
      expect_rcpt_list ;
      expect_text ;
      deliver_mail ;
      exception
        when ssmtp_reset =>
          put_line("reset received") ;
          --send_reset_ok ;
      end ;
      end loop ;
  exception
    when ssmtp_quit =>
      put_line("quit received") ;
      send_quit_ok ;
      close_connection ;
      -- EXIT ;    -- for VAX/VMS  O N L Y !!! (let command file distribute mail)
    when ssmtp_reset =>
      put_line("reset received") ;
      --send_reset_ok ;
    when sudden_connection_close =>
      put_line("Transport connection closed") ;
    when transport_error =>
      put_line("Transport error ") ;
    when others =>
      error_log ("Unknown exception in server smtp... exiting") ;
      raise ;
   end ;
  end loop ;
end ssmtp ;
--::::::::::::::
--stext.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01225-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         stext.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_text is
procedure expect_text ;
-- this program reads in mail from the transport layer and stores them
--  into ssmtp_globals.text as characters
--  exits upon end-of-mail indicator (i.e.  <crlf>.<crlf>)
--  may also exit with a raised exception:
--    ssmtp_quit :
--       if a quit command is received
--    ssmtp_reset :
--       if a reset is received
--    transport_close:
--       if a transport connection_aborted or connection_closed is found
--    transport_error :
--       if an unknown transport condition is found
--
end ssmtp_text ;
with text_io;            use text_io ;
with ssmtp_transport ;   use ssmtp_transport ;
with ssmtp_logger ;      use ssmtp_logger ;
with ssmtp_globals ;     use ssmtp_globals;
package body ssmtp_text is
procedure expect_text is
line : string (1..256) ;
len : integer ;
  begin
  send_string ("354 Start Mail Input") ;
  loop
    get_a_line(line,len) ;
    if line(1) = '.' then
      exit when len = 1 ;
      message_length := message_length + 1 ;
      message(message_length).message_line(1..len-1) := line(2..len) ;
      message(message_length).line_length := len-1 ;
    else
      message_length := message_length + 1 ;
      message(message_length).message_line(1..len) := line(1..len) ;
      message(message_length).line_length := len ;
    end if ;
    --&KJW 21-jul-85 message_length := message_length + 1 ;
    --&KJW 21-jul-85 message(message_length).message_line(1..len) := line(1..len) ;
    --&KJW 21-jul-85 message(message_length).line_length := len ;
    --&KJW 21-jul-85 exit when line(1) = '.' ;
    end loop ;
  exception
    when others =>
      error_log ("Exception in ssmtp.expect_text") ;
  end expect_text ;
end ssmtp_text ;
--::::::::::::::
--strans.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01226-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         strans.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_transport is
--
-- all the procedures required to interface to the transport service
--
procedure send_passive_open ;
-- send a listen on the well-known smtp socket
procedure wait_for_open  ;
-- wait for the open ok message
procedure close_connection ;
-- send a close to transport layer, wait for close ok message
procedure send_string (str : in string) ;
-- send a character string via the transport protocol
procedure get_command ;
-- this procedure gets an entire command from the transport layer
-- puts the first four letters, in lower case, in ssmtp_globals.command
-- and leaves the rest in ssmtp_globals.command_line
-- may raise the following exceptions:
--   sudden_connection_close
--   transport_error
procedure get_a_line( str : out string;
                      len : out integer ) ;
-- this procedure gets an entire line from the transport layer
-- may raise the following exceptions:
--   sudden_connection_close
--   transport_error
end ssmtp_transport ;
with cycle ;                            use cycle ;
with ssmtp_globals ;                 use ssmtp_globals ;
with text_io ;                       use text_io ;
with ssmtp_logger ;                  use ssmtp_logger ;
with with_ulp_communicate ;          use with_ulp_communicate ;
with with_tcp_communicate ;          use with_tcp_communicate ;
with t_tcp_globals_data_structures;    use t_tcp_globals_data_structures;
with buffer_data;                    use buffer_data ;
package body ssmtp_transport is
--&KJW 16-jul-1985 package int_io_16 is new integer_io(sixteen_bits) ;
package int_io_16 renames integer_io;
--------------------------------------------------------------------------------
--&KJW 16-jul-1985 current_lcn : lcn_ptr_type ;
current_lcn : tcb_ptr ;
--------------------------------------------------------------------------------
--
-- This is a local procedure to send a receive request to tcp
-- We should always have a few outstanding receives for tcp to put data into
--
procedure send_a_receive is
request_ok : boolean := true ;
--tcp_params : with_ulp_communicate.message(receive) ;   --&KJW 16-jul-85
tcp_params : with_tcp_communicate.message(receive) ;     --&KJW 16-jul-85
a_buf      : packed_buffer_ptr ;
begin
--&KJW 23-jul-85 put_line("Send a receive ") ;
buffget(a_buf,1) ;
if a_buf = null then
    error_log("ssmtp_transport.send_a_receive:  Could not get a buffer") ;
    raise constraint_error ;   -- crash the connection
else                                        --&KJW 22-jul-85
    a_buf.in_use := true ;                  --&KJW 22-jul-85
    a_buf.status := owner_tcp ;             --&KJW 22-jul-85
end if ;
tcp_params.receive_parameters.lcn := current_lcn ;
tcp_params.receive_parameters.bufptr := a_buf ;
tcp_params.receive_parameters.byte_count := 190 ;
message_for_tcp(tcp_params) ;
if not request_ok then
   raise transport_error ;
end if ;
for count in 1..4 loop        --&KJW 19-jul-85
  cycle.tcp_ip_subnet;        --&KJW 19-jul-85
end loop;            --&KJW 19-jul-85
exception
  when others =>
    error_log("Exception in send_a_receive") ;
    raise ;
end send_a_receive ;
----------------------------------------------------------------------
----------------------------------------------------------------------
procedure send_passive_open is
request_ok : boolean := true ;
--tcp_params : with_ulp_communicate.message(open) ;    --&KJW 16-jul-85
tcp_params : with_tcp_communicate.message ;        --&KJW 16-jul-85
open_parameters : open_params;                --&KJW 16-jul-85
begin
-- do a listen on the tcp port for smtp mail service.
--&KJW 23-jul-85 put_line("Send passive open ") ;
open_parameters.lcn := current_lcn ;        --&KJW 16-jul-85
open_parameters.local_port := 25 ;        --&KJW 16-jul-85
open_parameters.foreign_port := 0 ;        --&KJW 16-jul-85
open_parameters.foreign_net_host := 0 ;        --&KJW 16-jul-85
open_parameters.active_passive := passive ;    --&KJW 16-jul-85
open_parameters.buffer_size := 0 ;        --&KJW 16-jul-85
open_parameters.timeout := 2000 ;        --&KJW 16-jul-85
open_parameters.security := 0 ;            --&KJW 16-jul-85
open_parameters.precedence := 0 ;        --&KJW 16-jul-85
open_parameters.options := (1..50 => 0) ;    --&KJW 16-jul-85
tcp_params := ( with_tcp_communicate.open,    --&KJW 16-jul-85
            open_parameters );    --&KJW 16-jul-85
message_for_tcp(tcp_params) ;
if not request_ok then
   raise transport_error ;
end if ;
for count in 1..4 loop        --&KJW 19-jul-85
  cycle.tcp_ip_subnet;        --&KJW 19-jul-85
end loop;            --&KJW 19-jul-85
--&KJW 21-jul-85 current.lcn := tcp_params.open_parameters.lcn ;
exception
  when others =>
    error_log("Exception in send_passive_open") ;
    raise ;
end ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure wait_for_open is
reply : user_message ;
begin
--&KJW 23-jul-85 put_line("wait for open from transport") ;
loop
  --&KJW 21-jul-85 reply.lcn := current_lcn ;
  for count in 1..4 loop    --&KJW 19-jul-85
    cycle.tcp_ip_subnet;    --&KJW 19-jul-85
  end loop;            --&KJW 19-jul-85
  wait_for_tcp_message (reply) ;
  for count in 1..4 loop    --&KJW 19-jul-85
    cycle.tcp_ip_subnet;    --&KJW 19-jul-85
  end loop;            --&KJW 19-jul-85
  case reply.message_number is
    when -1 =>            --&KJW 19-jul-85
      null ;            --&KJW 19-jul-85
    when 23 =>
      --&KJW 23-jul-85 put_line("connection open") ;
      send_a_receive ; -- leave a receive pending
      transport_connection_open := true ;       --&KJW 21-jul-85
      exit ;
    when 14 =>
      current_lcn := reply.lcn ;
      --&KJW 23-jul-85 put_line("lcn saved") ;
    when 2 | 5 | 9 | 11 | 20 =>
      put("could not open, reason code = ") ;
      int_io_16.put(reply.message_number) ;
      put_line (" ." ) ;
    when 8 | 16 =>
      put_line("connection aborted") ;
      raise transport_error ;
    when others =>
      put("connection message ") ;
      int_io_16.put(reply.message_number) ;
      new_line ;
    end case ;
end loop ;
exception
  when others =>
    error_log("Exception in wait_for_open") ;
    raise ;
end wait_for_open ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure close_connection is
--
-- Send a close command to tcp and wait for a connection_closed response.
--
--tcp_params : with_ulp_communicate.message(close) ;    --&KJW 16-jul-85
tcp_params : with_tcp_communicate.message ;        --&KJW 16-jul-85
ab_cls_parameters : abort_close_params;            --&KJW 16-jul-85
reply : user_message ;
request_ok : boolean := true ;
begin
--&KJW 23-jul-85 put_line("waiting for close ok...") ;
loop
reply.lcn := current_lcn ;
for count in 1..4 loop        --&KJW 19-jul-85
  cycle.tcp_ip_subnet;        --&KJW 19-jul-85
end loop;            --&KJW 19-jul-85
wait_for_tcp_message (reply) ;
for count in 1..4 loop        --&KJW 19-jul-85
  cycle.tcp_ip_subnet;        --&KJW 19-jul-85
end loop;            --&KJW 19-jul-85
case reply.message_number is
  when -1 =>            --&KJW 19-jul85
    null;            --&KJW 19-jul-85
  when 8 | 16 =>
    put_line("connection aborted") ;
    transport_connection_open := false ;        --&KJW 21-jul-85
    exit ;
  when 6 =>
    --&KJW 23-jul-85 put_line("closing transport connection") ;    --&KJW 11-jul-85
    ab_cls_parameters.lcn := current_lcn;    --&KJW 16-jul-85
    tcp_params := ( with_tcp_communicate.close, --&KJW 16-jul-85
            ab_cls_parameters );    --&KJW 16-jul-85
    message_for_tcp(tcp_params) ;        --&KJW 11-jul-85
    if not request_ok then
      raise transport_error ;
    end if ;
    reply.lcn := current_lcn ;            --&KJW 11-jul-85
    loop            --&KJW 19-jul-85
      for count in 1..4 loop    --&KJW 19-jul-85
        cycle.tcp_ip_subnet;    --&KJW 19-jul-85
      end loop;            --&KJW 19-jul-85
      wait_for_tcp_message (reply) ;        --&KJW 11-jul-85
      for count in 1..4 loop    --&KJW 19-jul-85
        cycle.tcp_ip_subnet;    --&KJW 19-jul-85
      end loop;            --&KJW 19-jul-85
      case reply.message_number is        --&KJW 11-jul-85
        when -1 =>        --&KJW 19-jul-85
          null;            --&KJW 19-jul-85
        when 8 | 16 =>                --&KJW 11-jul-85
          put_line("connection aborted") ;    --&KJW 11-jul-85
          transport_connection_open := false ;  --&KJW 21-jul-85
          exit ;                --&KJW 11-jul-85
        when 18 =>                --&KJW 11-jul-85
          --&KJW 23-jul-85 put_line("connection closed") ;
          transport_connection_open := false ;  --&KJW 21-jul-85
          exit ;
        when others =>                --&KJW 11-jul-85
          put("connection message") ;        --&KJW 11-jul-85
          int_io_16.put(reply.message_number) ;   --&KJW 11-jul-85
          new_line ;                --&KJW 11-jul-85
      end case ;                --&KJW 11-jul-85
    end loop ;            --&KJW 19-jul-85
    exit ;            --&KJW 19-jul-85
  when others =>
    put("connection message") ;
    int_io_16.put(reply.message_number) ;
    new_line ;
  end case ;
end loop ;
--&KJW 23-jul-85 put_line("finished waiting") ;
exception
  when others =>
    error_log("Exception in close_connection") ;
    raise ;
end close_connection ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure send_string (str : in string) is
a_buffer : packed_buffer_ptr ;
send_block : send_params ;
--tcp_params : with_ulp_communicate.message(send) ;   --&KJW 16-jul-85
tcp_params : with_tcp_communicate.message(send) ;     --&KJW 16-jul-85
request_ok : boolean := true ;
begin
buffget(a_buffer,1) ;
if a_buffer = null then
    error_log("Could not get a buffer") ;
    raise constraint_error ;   -- crash the connection
else                                           --&KJW 22-jul-85
    a_buffer.in_use := true ;                  --&KJW 22-jul-85
    a_buffer.status := owner_tcp ;             --&KJW 22-jul-85
end if ;
---a_buffer.tcp_ptr := maximum_datagram_size - sixteen_bits(str'length) ;
-- patch for incorrect buffer spec
a_buffer.tcp_ptr := 254 - sixteen_bits(str'length) ;
--- a_buffer.size := str'length ;  --- patch for tcp error
a_buffer.size := str'length + 1 ;  --- patch for tcp error
-- put the string bytes into the end of the buffer
for i in 1..str'length loop
  a_buffer.byte(a_buffer.tcp_ptr + sixteen_bits(i))
      := character'pos(str(i)) ;
end loop ;
send_block.lcn := current_lcn ;
send_block.bufptr := a_buffer ;
send_block.byte_count := a_buffer.size ;
send_block.push_flag  := 0 ;
send_block.urg_flag := 0 ;
send_block.timeout  := 2000 ;
tcp_params.send_parameters := send_block ;
message_for_tcp(tcp_params) ;
if not request_ok then
  raise transport_error ;
end if ;
for count in 1..4 loop        --&KJW 19-jul-85
  cycle.tcp_ip_subnet;        --&KJW 19-jul-85
end loop;            --&KJW 19-jul-85
put("S: ") ;
put_line(str) ;
exception
  when others =>
    error_log("Exception in send_string") ;
    raise ;
  end ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure process_data ( buf : packed_buffer_ptr;
                         done : out boolean) is
data_byte : integer ;
len       : integer ;
begin
len := integer(buf.telnet_ptr - buf.tcp_ptr);
if len < 4 then
  command := "    " ;       --- blank it out
  put_line (" Bad command...incomplete") ;
else
  for i in 1..4 loop
    data_byte := integer(buf.byte(buf.tcp_ptr + sixteen_bits(i)-1)) ;
    if ((data_byte >= character'pos('A'))
          and (data_byte <= character'pos('Z'))) then
       command(i) := character'val( data_byte - character'pos('A')
                                + character'pos('a')) ; -- make it lower case
    else
      command(i) := character'val(data_byte) ;
    end if ;
  end loop ;
end if ;
for char in 1..max_command_length loop    --&KJW 16-jul-85
  command_parms(char) := ' ' ;        --&KJW 16-jul-85
end loop;                    --&KJW 16-jul-85
if len <= 4 then
  -- command_parms := (others => ' ') ;        --&KJW 16-jul-85
  parm_length   := 0 ;
else
  parm_length := len - 4 ;
  for i in 1..parm_length loop
    data_byte := integer(buf.byte(sixteen_bits(i)+buf.tcp_ptr+3))  ;
    --&KJW 21-jul-85 if ((data_byte >= character'pos('A')) and (data_byte <= character'pos('Z'))) then
    --&KJW 21-jul-85   command_parms(i) := character'val(data_byte - character'pos('A')
    --&KJW 21-jul-85                       + character'pos('a')) ; -- make it lower case
    --&KJW 21-jul-85 else
    --&KJW 21-jul-85   command_parms(i) := character'val(data_byte) ;
    --&KJW 21-jul-85 end if ;
    command_parms(i) := character'val(data_byte) ;
  end loop ;
end if ;
put("R: ") ;
put(command) ;
put_line(command_parms) ;
done := true ;      -- single segment replies only for test
exception
  when others =>
    error_log("Exception in process_data") ;
    raise ;
end process_data ;
-------------------------------------------------------------------------------
procedure get_command is
  len : integer ;          -- test
  cmd : string (1..256) ;  -- test
  reply_done : boolean := false ;
  tcp_reply : with_ulp_communicate.user_message ;
begin
command := "    " ;
--&KJW 23-jul-85 put_line("waiting for command...") ;
while not reply_done loop
  tcp_reply.lcn := current_lcn ;
  for count in 1..4 loop    --&KJW 19-jul-85
    cycle.tcp_ip_subnet;    --&KJW 19-jul-85
  end loop;            --&KJW 19-jul-85
  wait_for_tcp_message (tcp_reply) ;
  for count in 1..4 loop    --&KJW 19-jul-85
    cycle.tcp_ip_subnet;    --&KJW 19-jul-85
  end loop;            --&KJW 19-jul-85
  case tcp_reply.message_number is
    when -1 =>            --&KJW 19-jul-85
      null;            --&KJW 19-jul-85
    when 16 =>
      put_line("connection aborted") ;
      raise sudden_connection_close ;
    when 10 =>
      process_data (tcp_reply.data_buffer, reply_done) ;
      tcp_reply.data_buffer.in_use := false ;   --&KJW 22-jul-85
      tcp_reply.data_buffer.status := none ;    --&KJW 22-jul-85
      buffree(tcp_reply.data_buffer,0) ;        --&KJW 22-jul-85
      send_a_receive ;  -- replace the receive
    when others =>
      put("connection message") ;
      int_io_16.put(tcp_reply.message_number) ;
      new_line ;
  end case ;
end loop ;
--&KJW 23-jul-85 put_line("finished waiting") ;
exception
  when others =>
    put_line("exception in get_command") ;
    raise ;
end get_command ;
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
procedure process_str  ( buf  : packed_buffer_ptr;
                         done : out boolean;
                         str  : out string ;
                         len  : out integer ) is
str1      : string(1..255)  ;
len1      : integer ;
data_byte : integer ;
begin
len1 := integer(buf.telnet_ptr - buf.tcp_ptr);
for i in 1..len1 loop
  str1(i) := character'val(buf.byte(buf.tcp_ptr + sixteen_bits(i)-1)) ;
  end loop ;
put("R: ") ;
put_line(str1(1..len1)) ;
str(1..len1) := str1(1..len1) ;
len := len1 ;
done := true ;      -- single segment replies only for test
exception
  when others =>
    error_log("Exception in process_str") ;
    raise ;
end process_str ;
-------------------------------------------------------------------------------
procedure get_a_line( str : out string ;
                      len : out integer ) is
str_done : boolean := false ;
tcp_reply : with_ulp_communicate.user_message ;
begin
--&KJW 23-jul-85 put_line("waiting for string...") ;
while not str_done loop
  tcp_reply.lcn := current_lcn ;
  for count in 1..4 loop    --&KJW 19-jul-85
    cycle.tcp_ip_subnet;    --&KJW 19-jul-85
  end loop;            --&KJW 19-jul-85
  wait_for_tcp_message (tcp_reply) ;
  for count in 1..4 loop    --&KJW 19-jul-85
    cycle.tcp_ip_subnet;    --&KJW 19-jul-85
  end loop;            --&KJW 19-jul-85
  case tcp_reply.message_number is
    when -1 =>            --&KJW 19-jul-85
      null;            --&KJW 19-jul-85
    when 16 =>
      put_line("connection aborted") ;
      raise sudden_connection_close ;
    when 10 =>
      process_str (tcp_reply.data_buffer, str_done, str, len) ;
      tcp_reply.data_buffer.in_use := false ;   --&KJW 22-jul-85
      tcp_reply.data_buffer.status := none ;    --&KJW 22-jul-85
      buffree(tcp_reply.data_buffer,0) ;        --&KJW 22-jul-85
      send_a_receive ;  -- replace the receive
    when others =>
      put("connection message") ;
      int_io_16.put(tcp_reply.message_number) ;
      new_line ;
  end case ;
end loop ;
--&KJW 23-jul-85 put_line("finished waiting") ;
exception
  when others =>
    put_line("exception in get_a_line") ;
    raise ;
end get_a_line ;
end ssmtp_transport ;
--::::::::::::::
--ucomm.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01227-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ucomm.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_commands is
--
-- This package contains all the commands sent by the usmtp.
--
--
--
procedure send_data_to_server ;
--
-- Sends a DATA command to the ssmtp.
--
--
procedure send_rcpt_to_server(name : string) ;
--
-- Sends a RCPT command to the ssmtp.
--
--
procedure send_helo ;
--
-- Sends a HELO command to the ssmtp.
--
--
procedure send_mail (name : string) ;
--
-- Sends a MAIL command to the ssmtp.
--
--
procedure send_quit ;
--
-- Sends a QUIT command to the ssmtp.
--
--
procedure send_reset ;
--
-- Sends a RSET command to the ssmtp.
--
--
end usmtp_commands ;
with usmtp_utils ;       use usmtp_utils ;
with usmtp_network ;     use usmtp_network ;
with text_io ;           use text_io ;
package body usmtp_commands is
--
-- This package contains all the commands sent by the usmtp.
--
--
--
--
procedure send_data_to_server is
--
-- Send the DATA command to tcp.
--
begin
send_string("DATA") ;
exception
  when others =>
    put_line("exception in send_data_to_server") ;
    raise ;
end ;
--
--
--
procedure send_rcpt_to_server(name : string) is
--
-- Send the RCPT command to tcp. Formats the name into a proper command line
--  and calls send_string.
--
line : string (1..256) ;
len : integer ;
prep : string (1..9) := "RCPT to: " ;
begin
  len := name'length + prep'length ;
  line(1..len) := prep & name ;
  send_string(line (1..len));
exception
  when others =>
    put_line("exception in send_rcpt_to_server") ;
    raise ;
end send_rcpt_to_server ;
procedure  send_helo is
--
-- Send the HELO command to tcp. Formats the host name into a proper command
--  line and calls send_string.
-- To rehost, change my_host_name and recompile.
--
line : string (1..256) ;
len : integer ;
my_host_name : constant string(1..13)  := "NOSCAda.WICAT" ;
begin
len := 5 + my_host_name'length ;
line(1..len) := "HELO " & my_host_name ;
send_string(line(1..len)) ;
exception
  when others =>
    put_line("exception in send_helo") ;
    raise ;
end send_helo ;
--
--
--
procedure send_mail (name : string) is
line : string (1..256) ;
len : integer ;
begin
len := 11 + name'length ;
line(1..len) := "MAIL from: " & name ;
send_string(line(1..len)) ;
exception
  when others =>
    put_line("exception in send_mail") ;
    raise ;
end send_mail ;
--
--
--
procedure send_quit is
begin
send_string("QUIT") ;
exception
  when others =>
    put_line("exception in send_quit") ;
    raise ;
end ;
--
--
--
procedure send_reset is
begin
send_string("RSET") ;
exception
  when others =>
    put_line("exception in send_rset ") ;
    raise ;
end ;
--
--
--
end usmtp_commands ;
--::::::::::::::
--uconn.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01228-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         uconn.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_connections is
--
-- This pacakge contains the connection related functions for the
--   communications with the ssmtp.
-- Allows opening connections, sending data, closing connections,
--    and forcing resets on connections.
--
--
--
procedure establish_connection_and_send_helo ;
--
-- This procedure performs the follwing functions:
--   1. request a transport connection to the well-known ssmtp network address
--   2. wait for the connection to be successfully opened
--   3. wait for a greeting reply from the ssmtp and print it
--   4. send a helo to the ssmtp
--   5. wait for a helo_ok reply from the ssmtp
--
-- If proper handshaking fails (connection not opened, incorrect reply
--   from ssmtp, etc.; this procedure queries the user for retries and loops
--   if requested. Exits with an excetpion if unsuccessful and no retry
--   requested.
--
-- raises the following exceptions:
--   abort_ssmtp if connection fails and user does not request retry
--
--
--
procedure close_smtp_connection ;
--
-- Sends a QUIT command to the ssmtp, waits for a proper reply, and
--  sends a close command to the transport layer for a normal connection
--  close.
--
--
--
end usmtp_connections ;
with text_io;        use text_io ;
with usmtp_utils ;   use usmtp_utils ;
with usmtp_network;  use usmtp_network ;
with usmtp_commands; use usmtp_commands;
package body usmtp_connections is
--
-- Package implementation for :  Labtek WICAT
--                               tcp transport service (esystems version)
--                               TeleSoft/Ada (Version 1.3)
procedure establish_connection_and_send_helo is
--
-- This procedure performs the follwing functions:
--   1. request a tcp connection to the well-known ssmtp socket
--   2. wait for a greeting reply (220) from the ssmtp and print it
--   3. send a helo to the ssmtp
--   4. wait for a helo_ok reply from the ssmtp
--
-- If proper handshaking fails (connection not opened, incorrect reply
--   from ssmtp, etc.; This procedure exits with an exception
--   if unsuccessful. Connection is closed if this occurs.
--
-- raises or propagates the following exceptions:
--   unexpected_reply if bad reply from ssmtp
--   smtp_error       if 4xx or 5xx from ssmtp
--   tcp reset        if connection lost or could not open
--
--
  host_name    : string (1..80) ;
  eol          : integer := 0 ;
  reply        : string (1..80) ;
begin
  put_line("Establish Connection to Remote Host ") ;
  put("enter remote host name -> ") ;
  get_line(host_name, eol) ;
  send_open_to_transport_layer(host_name(1..eol)) ;
  get_reply(reply) ;
  if reply(1..3) /= open_ok then
    put_line("Could not open...bad reply") ;
    put_line("Aborting connection") ;
    send_abort_to_transport ;
    raise tcp_reset ;
  else
    --&KJW 23-jul-85 put_line("Sending helo...") ;
    send_helo ;
    get_reply(reply) ;
    if reply(1..3) /= helo_ok then
      put_line("server not responding");
      put_line("Aborting connection") ;
      send_aborT_to_transport ;
      raise smtp_error ;
    end if ;
  end if ;
exception
  when smtp_error | tcp_reset =>
    raise ;
  when others =>
    put_line("unexpected exception in establish_connection") ;
    raise ;
end establish_connection_and_send_helo;
procedure close_smtp_connection is
  reply : string(1..80) ;        --&KJW 11-jul-85;
begin
send_quit ;
get_reply(reply) ;            --&KJW 11-jul-85;
if reply(1..3) /= quit_ok then        --&KJW 11-jul-85;
  put_line("Quit reply not received") ;    --&KJW 11-jul-85;
  raise unexpected_reply ;        --&KJW 11-jul-85;
end if ;                --&KJW 11-jul-85;
send_close_to_transport_layer ;
exception
  when others =>
    put_line("exception in close_smtp_connection") ;
    raise ;
end close_smtp_connection ;
end usmtp_connections ;
--::::::::::::::
--unet.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01229-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         unet.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_network is
--
-- This package contains the usmtp interfaecs to the network transport
--   protocol process and other network-related functions.
--
--
procedure send_open_to_transport_layer(host_id : string) ;
--
-- Sends an open connection request to the transport layer.
--
--
procedure send_abort_to_transport ;
--
-- Sends an abort command to the transport layer to force termination
--  of a connection.
--
--
procedure send_string (str : in string) ;
--
-- formats an ascii string into the desired transport form and sends it
--   to the ssmtp
--
procedure send_close_to_transport_layer ;
--
-- Sends a close command to the transport layer to force a normal connection
--   close.
--
--
procedure get_reply (reply  : out string) ;
--
-- This procedure gets a reply string from the transport layer.
--  Converts transport layer format to string. Performs as many
--  transport layer reads as necessary until a complete response is found
--  (in case of multiline responses, etc.)
--
end usmtp_network ;
with cycle ;                            use cycle ;
with buffer_data ;                   use buffer_data ;
with with_ulp_communicate ;          use with_ulp_communicate ;
with with_tcp_communicate ;          use with_tcp_communicate ;
with t_tcp_globals_data_structures;    use t_tcp_globals_data_structures;
with text_io;                        use text_io ;
with usmtp_utils ;                   use usmtp_utils ;
with xhost ;                         use xhost ;
with system ;                        use system ;
--
package body usmtp_network is
--
-- Implementation for:    LabTek Wicat
--                        tcp transport layer (e-system version)
--                        TeleSoft Ada
--
--
--&KJW 16-jul-85 package int_io_32 is new integer_io(thirtytwo_bits) ;
--&KJW 16-jul-85 package int_io_16 is new integer_io(sixteen_bits) ;
package int_io_32 renames text_io.long_integer_io;    --&KJW 16-jul-85
package int_io_16 renames text_io.     integer_io;    --&KJW 16-jul-85
--
--
--&KJW 16-jul-85 current_lcn : lcn_ptr_type ;  -- the lcn for the current open connection
current_lcn : tcb_ptr ;  -- the lcn for the current open connection
--
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
----
-- This is a local procedure to send a receive request to tcp
-- We should always have a few outstanding receives for tcp to text_io.put data into
--
procedure send_a_receive is
request_ok : boolean := true ;
--&KJW 16-jul-85 tcp_params : with_tcp_communicate.message(receive) ;
tcp_params : with_tcp_communicate.message ;    --&KJW 16-jul-85
receive_parameters : receive_params;        --&KJW 16-jul-85
a_buf      : packed_buffer_ptr ;
begin
--&KJW 23-jul-85 text_io.put_line("Send a receive ") ;
buffget(a_buf,1) ;
if a_buf = null then
    text_io.put_line("usmtp_network.send_a_receive:  Could not get a buffer") ;
    raise constraint_error ;   -- crash the connection
else
    a_buf.in_use := true ;                      --&KJW 22-jul-85
    a_buf.status := owner_tcp ;                 --&KJW 22-jul-85
end if ;
--&KJW 16-jul-85 tcp_params.receive_parameters.lcn := current_lcn ;
--&KJW 16-jul-85 tcp_params.receive_parameters.bufptr := a_buf ;
--&KJW 16-jul-85 tcp_params.receive_parameters.byte_count := 190 ;
receive_parameters.lcn := current_lcn ;        --&KJW 16-jul-85
receive_parameters.bufptr := a_buf ;        --&KJW 16-jul-85
receive_parameters.byte_count := 190 ;        --&KJW 16-jul-85
tcp_params := ( with_tcp_communicate.receive,    --&KJW 16-jul-85
                receive_parameters );        --&KJW 16-jul-85
message_for_tcp(tcp_params) ;
if not request_ok then
   raise constraint_error ;  -- crash the connection
end if ;
for count in 1..4 loop            --&KJW 19-jul-85
  cycle.tcp_ip_subnet ;            --&KJW 19-jul-85
end loop ;                --&KJW 19-jul-85
exception
  when others =>
    text_io.put_line("Exception in send_a_receive") ;
    raise ;
end send_a_receive ;
--
procedure send_string(str : in string) is
--
-- Given an ascii string, this procedure converts it to the
--  tcp format (byte array), formats a tcp send call, and calls the
--  tcp interface.
--
a_buffer   : packed_buffer_ptr ;
tcp_params : message(send) ;
send_block : send_params ;
request_ok : boolean := true ;
begin
  for count in 1..10 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  buffget(a_buffer, 0) ;
  -- patch for incorrect buffer spec
  --a_buffer.tcp_ptr := maximum_datagram_size - sixteen_bits(str'length) ;
  if a_buffer = null then
    text_io.put_line("usmtp_network:  Out of buffers.") ;
    raise constraint_error;
  else
    a_buffer.in_use := true ;
    a_buffer.status := owner_tcp ;
  end if ;
  a_buffer.tcp_ptr := 254 - sixteen_bits(str'length) ;
  text_io.put("TCP_PTR IS "); int_io_16.put(a_buffer.tcp_ptr,0); new_line;
  --- a_buffer.size := str'length ;  --- patch for tcp error :
  a_buffer.size := str'length + 1 ;  --- patch for tcp
  -- text_io.put the string bytes into the end of the buffer
  for i in 1..str'length loop
    a_buffer.byte(a_buffer.tcp_ptr + sixteen_bits(i))
        := character'pos(str(i)) ;
  end loop ;
  send_block.lcn := current_lcn ;
  send_block.bufptr := a_buffer ;
  send_block.byte_count := a_buffer.size ;
  send_block.push_flag  := 0 ;
  send_block.urg_flag := 0 ;
  send_block.timeout  := 2000 ;
  tcp_params.send_parameters := send_block ;
  message_for_tcp(tcp_params) ;
  if not request_ok then
    raise tcp_reset ;
  end if ;
  for count in 1..10 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
text_io.put("S: ") ;
  text_io.put_line(str) ;
exception
  when tcp_reset =>
    text_io.put_line("TCP error in send_string") ;
    raise ;
  when others =>
    text_io.put_line("exception in send_string") ;
    raise ;
  end ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure  send_abort_to_transport is
--
-- Format and send a tcp abort command to reset the connection.
-- May wait for connection_closed message from tcp.
--
--&KJW 16-jul-85 tcp_params : message(abor_t) ;
tcp_params : message ;    --&KJW 16-jul-85
ab_cls_parameters : abort_close_params;        --&KJW 16-jul-85
reply : user_message ;
request_ok : boolean := true ;
begin
--&KJW 23-jul-85 text_io.put_line("send_abort_to_transport") ;
ab_cls_parameters.lcn := current_lcn ;        --&KJW 16-jul-85
tcp_params := ( with_tcp_communicate.abor_t,    --&KJW 16-jul-85
                ab_cls_parameters );        --&KJW 16-jul-85
message_for_tcp(tcp_params) ;
if not request_ok then
  raise tcp_reset ;
end if ;
--&KJW 23-jul-85 text_io.put_line("waiting for abort ok...") ;
loop
  reply.lcn := current_lcn ;
  for count in 1..4 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  wait_for_tcp_message (reply) ;
  for count in 1..4 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  case reply.message_number is
    when -1 =>                --&KJW 19-jul-85
      null ;                --&KJW 19-jul-85
    when 8 | 16 =>
      text_io.put_line("connection aborted") ;
      exit ;
    when others =>
      text_io.put("connection message") ;
      int_io_16.put(reply.message_number) ;
      new_line ;
  end case ;
end loop ;
exception
  when tcp_reset =>
    text_io.put_line("TCP error in send_abort_to_transport") ;
    raise ;
  when others =>
    text_io.put_line("exception in send_abort_to_transport ") ;
    raise ;
end ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure send_to_transport(data_line : in string ) is
--
-- Call send_string to send a string.
--
begin
send_string(data_line) ;
exception
  when others =>
    text_io.put_line("exception in send_to_transport") ;
    raise ;
end ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure convert_to_lower_case (str : in out string) is
begin
 for i in 1..str'length loop
   if ( str(i) IN 'A'..'Z' ) then
     str(i) := character'val(character'pos(str(i)) + 32) ;
   end if ;
  end loop ;
end convert_to_lower_case ;
procedure send_open_to_transport_layer(host_id : string) is
--
-- Format a tcp_open and wait for connection_opened tcp response.
--
host_name_ok : boolean ;
host_addr    : buffer_data.thirtytwo_bits ;
--&KJW 16-jul-85 tcp_params   : message(open) ;
tcp_params   : message ;    --&KJW 16-jul-85
open_parameters : open_params;    --&KJW 16-jul-85
reply        : user_message ;
request_ok   : boolean := true ;
id           : string (1..host_id'length) ;
begin
  id := host_id ;
  convert_to_lower_case(id) ;
  translate_host_name_to_address(id, host_addr, host_name_ok) ;
  if not host_name_ok then
    text_io.put_line("Bad host name") ;
    raise tcp_reset ;
  end if ;
  --&KJW 23-jul-85 text_io.put("send_open_to_transport_layer, host= ");
  --&KJW 23-jul-85 text_io.put(id) ;
  --&KJW 23-jul-85 text_io.put(" = ") ;
  --&KJW 23-jul-85 int_io_32.put(host_addr) ;
  --&KJW 23-jul-85 new_line ;
  --&KJW 16-jul-85 tcp_params.open_parameters.lcn := current_lcn ;
  --&KJW 16-jul-85 tcp_params.open_parameters.local_port := 26 ;
  --&KJW 16-jul-85 tcp_params.open_parameters.foreign_net_host := host_addr ;
  --&KJW 16-jul-85 tcp_params.open_parameters.foreign_port := 25 ;
  --&KJW 16-jul-85 tcp_params.open_parameters.active_passive := active ;
  --&KJW 16-jul-85 tcp_params.open_parameters.buffer_size := 0 ;
  --&KJW 16-jul-85 tcp_params.open_parameters.timeout := 2000 ;
  --&KJW 16-jul-85 tcp_params.open_parameters.security := 0 ;
  --&KJW 16-jul-85 tcp_params.open_pa.ameters.precedence := 0 ;
  --&KJW 16-jul-85 tcp_params.open_parame0ers.options := (others => 0) ;
  open_parameters.lcn := current_lcn ;            --&KJW 16-jul-85
  open_parameters.local_port := 26 ;            --&KJW 16-jul-85
  open_parameters.foreign_net_host := host_addr ;    --&KJW 16-jul-85
  open_parameters.foreign_port := 25 ;            --&KJW 16-jul-85
  open_parameters.active_passive := active ;        --&KJW 16-jul-85
  open_parameters.buffer_size := 0 ;            --&KJW 16-jul-85
  open_parameters.timeout := 2000 ;            --&KJW 16-jul-85
  open_parameters.security := 0 ;            --&KJW 16-jul-85
  open_parameters.precedence := 0 ;            --&KJW 16-jul-85
  open_parameters.options := (1..50 => 0) ;        --&KJW 16-jul-85
  tcp_params := ( with_tcp_communicate.open,        --&KJW 16-jul-85
                  open_parameters ) ;            --&KJW 16-jul-85
  message_for_tcp(tcp_params) ;
  if not request_ok then
    raise tcp_reset ;
  end if ;
  current_lcn := tcp_params.open_parameters.lcn ;
  --&KJW 23-jul-85 text_io.put_line("wait for open from transport") ;
  loop
    reply.lcn := current_lcn ;
    for count in 1..4 loop        --&KJW 19-jul-85
      cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
    end loop ;                --&KJW 19-jul-85
    wait_for_tcp_message (reply) ;
    for count in 1..4 loop        --&KJW 19-jul-85
      cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
    end loop ;                --&KJW 19-jul-85
    case reply.message_number is
      when -1 =>            --&KJW 19-jul-85
        null ;                --&KJW 19-jul-85
      when 23 =>
        --&KJW 23-jul-85 text_io.put_line("connection open") ;
        exit ;
      when 14 =>
        current_lcn := reply.lcn ;
        --&KJW 23-jul-85 text_io.put_line("lcn saved") ;
      when 2 | 5 | 9 | 11 | 20 =>
        text_io.put("could not open, reason code = ") ;
        int_io_16.put(reply.message_number) ;
        text_io.put_line (" ." ) ;
        raise tcp_reset ;
      when 8 | 16 =>
        text_io.put_line("connection aborted") ;
        raise tcp_reset ;
      when others =>
        text_io.put("connection message") ;
        int_io_16.put(reply.message_number) ;
        new_line ;
      end case ;
  end loop ;
  send_a_receive ; -- leave an outstanding receive
exception
  when tcp_reset =>
    raise ;
  when others =>
    text_io.put_line("exception in send_open_to_transport ") ;
    raise ;
end send_open_to_transport_layer ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
procedure send_close_to_transport_layer is
--
-- Send a close command to tcp and wait for a connection_closed response.
--
--&KJW 16-jul-85 tcp_params : message(close) ;
tcp_params : message ;                --&KJW 16-jul-85
ab_cls_parameters : abort_close_params ;    --&KJW 16-jul-85
reply : user_message ;
request_ok : boolean := true ;
begin
--&KJW 23-jul-85 text_io.put_line ("Close tcp connection") ;
--&KJW 16-jul-85 tcp_params.abort_close_parameters.lcn := current_lcn ;
ab_cls_parameters.lcn := current_lcn ;        --&KJW 16-jul-85
tcp_params := ( with_tcp_communicate.close,    --&KJW 16-jul-85
                ab_cls_parameters ) ;        --&KJW 16-jul-85
message_for_tcp(tcp_params) ;
if not request_ok then
  raise tcp_reset ;
end if ;
for count in 1..4 loop            --&KJW 19-jul-85
  cycle.tcp_ip_subnet ;            --&KJW 19-jul-85
end loop ;                --&KJW 19-jul-85
--&KJW 23-jul-85 text_io.put_line("waiting for close ok...") ;
loop
  reply.lcn := current_lcn ;
  for count in 1..4 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  wait_for_tcp_message (reply) ;
  for count in 1..4 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  case reply.message_number is
    when -1 =>                --&KJW 19-jul-85
      null ;                --&KJW 19-jul-85
    when 8 | 16 =>
      text_io.put_line("connection aborted") ;
      exit ;
    when 6 | 18 =>    --&KJW 11-jul-85
      --&KJW 23-jul-85 text_io.put_line("connection closed") ;
      exit ;
    when others =>
      text_io.put("connection message") ;
      int_io_16.put(reply.message_number) ;
      new_line ;
  end case ;
end loop ;
exception
  when tcp_reset =>
    text_io.put_line("TCP error in send_close") ;
    raise ;
  when others =>
    text_io.put_line("exception in send_close ") ;
    raise ;
end ;
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
-- this procedure gets tcp data buffers until a reply  terminator is found
--
-- converts system.byte into ascii chars
-- keeps gathering characters until an end-of-reply (eor) is found.
-- an eor is indicated by a <crlf> if a single line reply or a
--  <crlf>.<crlf> if a multiline reply.
-- also separates the received data into the reply and any excess found in the
--  segment after the <crlf>. Note that there should not be anything
--  after the <crlf> if the server_smtp is ok.
--
-- all this is necessary because we cannot rely on the entire
--  reply being in a single tcp segment.
--
--    <reply_format>        = NNN<multiline_indicator>reply_text<eor>
--    <multiline_indicator> = <space> | -
--    <eor>                 = <crlf> | <crlf>.<crlf>
--
-- accepts all tcp messages
--  if tcp resets or closes  it will raise tcp_reset
--  tosses all others away
--
procedure process_data ( buf : packed_buffer_ptr;
                         str : out string ) is
--&KJW 17-jul-85 str1 : string (1..str'length) := ( others => ' ') ;
str1 : string (1..str'length) ;        --&KJW 17-jul-85
len : integer ;
begin
len := integer(buf.telnet_ptr-buf.tcp_ptr);
for i in 1..len loop
  str1(i) := character'val(buf.byte(buf.tcp_ptr+sixteen_bits(i)-1) ) ;
end loop ;
for i in len+1..str'length loop        --&KJW 17-jul-85
  str1(i) := ' ';            --&KJW 17-jul-85
end loop;                --&KJW 17-jul-85
text_io.put("R: ") ;
text_io.put_line(str1(1..len)) ;
str(1..3) := str1(1..3) ;
--&KJW 17-jul-85 str(4..str'length) := (others => ' ') ;
for i in 4 .. str'length loop        --&KJW 17-jul-85
  str(i) := ' ';            --&KJW 17-jul-85
end loop;                --&KJW 17-jul-85
end process_data ;
procedure get_reply (reply  : out string) is
  eor_found : boolean := false ;
  rep : string (1..80) ;           -- for debug
  erep : integer ;                 -- for debug
  reply_done : boolean := false ;
  tcp_reply : user_message ;
begin
reply(1..3) := "   " ;
--&KJW 23-jul-85 text_io.put_line("waiting for reply...") ;      --&KJW 20-jul-85
while not reply_done loop
  tcp_reply.lcn := current_lcn ;
  for count in 1..4 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  wait_for_tcp_message (tcp_reply) ;
  for count in 1..4 loop        --&KJW 19-jul-85
    cycle.tcp_ip_subnet ;        --&KJW 19-jul-85
  end loop ;                --&KJW 19-jul-85
  case tcp_reply.message_number is
    when -1 =>                --&KJW 19-jul-85
      null ;                --&KJW 19-jul-85
    when 16 =>
      text_io.put_line("connection aborted") ;
      raise tcp_reset ;
    when 10 =>
      process_data (tcp_reply.data_buffer, reply) ;
      tcp_reply.data_buffer.in_use := false ;
      tcp_reply.data_buffer.status := none ;
      buffree(tcp_reply.data_buffer,0) ;
      send_a_receive ;
      reply_done := true ;  -- single segment replies only!
    when others =>
      text_io.put("connection message") ;
      int_io_16.put(tcp_reply.message_number) ;
      new_line ;
  end case ;
end loop ;
--&KJW 23-jul-85 text_io.put_line("finished waiting") ;      --&KJW 20-jul-85
exception
  when others =>
    text_io.put_line("exception in get_reply") ;
    raise ;
end get_reply ;
end usmtp_network ;
--::::::::::::::
--urcpt.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01230-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         urcpt.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_rcpt is
--
-- This package handles the recipient list mode.
--
procedure send_rcpt_list ;
--
-- Query the user for each recipient name in the list, send
--  the RCPT command, and wait for a response. Must receive
--  at least one rcpt_ok respone from the ssmtp before proceeding.
--
end usmtp_rcpt ;
with text_io;           use text_io ;
with usmtp_utils ;      use usmtp_utils ;
with usmtp_connections; use usmtp_connections ;
with usmtp_commands;    use usmtp_commands;
with usmtp_network ;    use usmtp_network ;
package body usmtp_rcpt is
procedure send_rcpt_list is
--
-- For each recipient, query the user for the name and send it using
--   the send_rcpt procedure in usmtp_network.
-- Current limitations:
--   does not do any processing on user name strings
--   does not support local lists
--
--&KJW 21-jul-85 a_rcpt : boolean := false ;
rcpt_count : natural := 0 ;             --&KJW 21-jul-85
user_name : string (1..80) ;
eol : integer := 0 ;
reply : string (1..80) ;
begin
  put_line("Enter rcpt list 1 at a time ... nul line to terminate list") ;
  loop
    put ("To: ") ;
    get_line(user_name,eol);
    if eol /= 0 then
      send_rcpt_to_server(user_name(1..eol)) ;
      get_reply(reply) ;
      if reply(1..3) = rcpt_ok then
        --&KJW 23-jul-85 put_line ("rcpt ok") ;
        --&KJW 21-jul-85 a_rcpt := true ;
        rcpt_count := rcpt_count + 1 ;  --&KJW 21-jul-85
      --&KJW 23-jul-85 else
        --&KJW 23-jul-85 put_line("rcpt not ok") ;
      end if ;
    else
      --&KJW 21-jul-85 if not a_rcpt then
      if rcpt_count < 1 then            --&KJW 21-jul-85
        put_line ("Must enter at least one rcpt") ;
      else
        exit ;
      end if ;
    end if ;
  end loop ;
exception
  when others =>
    put_line("exception in send_rcpt_list") ;
    raise ;
end send_rcpt_list ;
end usmtp_rcpt ;
--::::::::::::::
--usmtp.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01231-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         usmtp.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
with real_time_clock_and_date;
use real_time_clock_and_date;
with text_io;             use text_io ;
with usmtp_utils ;        use usmtp_utils ;
with usmtp_connections;   use usmtp_connections ;
with usmtp_network ;      use usmtp_network ;
with usmtp_rcpt ;         use usmtp_rcpt ;
with usmtp_text ;         use usmtp_text ;
with usmtp_commands ;     use usmtp_commands ;
with buffer_data ;        use buffer_data ;
procedure usmtp is
name        : string (1..255) ;
name_length : integer ;
--&KJW 17-jul-85 continue    : string (1..255) := ('y', others => ' ') ;
continue    : string (1..255) ;        --&KJW 17-jul-85
len         : integer ;
reply       : string(1..80) ;
begin
start_local_clock;
continue(1) := 'y';            --&KJW 17-jul-85
for i in 2..continue'length loop    --&KJW 17-jul-85
  continue(i) := ' ';            --&KJW 17-jul-85
end loop;                --&KJW 17-jul-85
put_line ("SMTP ver 1.0") ;
buffer_data.init ;
while continue(1) = 'y' loop
  begin
  establish_connection_and_send_helo ;
  put("Enter sender's name -> ");
  get_line(name,name_length) ;
  send_mail(name(1..name_length));
  get_reply(reply) ;
  if reply(1..3) /= helo_ok then
    put_line("Mail reply not received") ;
    raise unexpected_reply ;
  end if ;
  while continue(1) = 'y' loop
    send_rcpt_list ;
    send_text ;
    put_line("Any more mail for this host (y for yes)? " ) ;
    get_line(continue,len) ;
  end loop ;
--&KJW 11-jul-85 send_quit ;
--&KJW 11-jul-85 send_close_to_transport_layer ;
close_smtp_connection ;    --&KJW 11-jul-85
exception
  when abort_usmtp =>
    put_line(" Exit SMTP ") ;
    raise ;
  when smtp_error =>
    put_line(" server replies error in transmission... connection aborted ") ;
  when unexpected_reply =>
    put_line(" error in server - unexpected reply... connection aborted ") ;
  when tcp_reset =>
    put_line(" error in tcp transmission... connection aborted ") ;
  when others =>
    put_line ("unknown exception in smtp... exiting") ;
    raise ;
  end ;
put_line("Any more mail to send  (y for yes)? " ) ;
get_line(continue,len) ;
end loop ;
put_line(" Exit SMTP ") ;
exception
  when others =>
    put_line ("unknown exception in smtp... exiting") ;
end usmtp ;
--::::::::::::::
--utext.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01232-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         utext.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_text is
--
-- This package supports the mail data entry mode of usmtp.
--
procedure send_text ;
--
-- Continually get lines from the user and send them to the transport
--   layer until end-of-message is found.
--
end usmtp_text ;
with text_io;           use text_io ;
with usmtp_utils ;      use usmtp_utils ;
with usmtp_connections; use usmtp_connections ;
with usmtp_network ;    use usmtp_network ;
with usmtp_commands ;   use usmtp_commands ;
with usmtp_network ;    use usmtp_network ;
package body usmtp_text is
procedure send_text is
--
-- keep getting lines of data from the user and sending them to the transport
--   layer until an end-of-message is found.
--
-- Limitations:
--  Current end of message :  <CRLF>.<CRLF>
--  does not support mailing files.
--
  data_line : string(1..max_line_len) ;
  eol : natural ;
  reply : string(1..80) ;
  eof : boolean := false ;
  --&KJW 21-jul-85 end_mark : string (1..1) ;  -- could be a character if TS allowed it
begin
--&KJW 21-jul-85 end_mark(1) := '.' ;
send_data_to_server ;
get_reply(reply) ;
if reply(1..3) /= send_data_ok then
  put_line("server not responding") ;
  send_abort_to_transport ;
else
  put_line("Enter data. Terminate message with <CRLF>.<CRLF> ") ;
  while not eof loop
    get_line(data_line,eol) ;
    --&KJW 21-jul-85 if data_line(1..eol) = end_mark then
    --&KJW 21-jul-85   put_line("End of file found") ;
    --&KJW 21-jul-85   eof := true ;
    --&KJW 21-jul-85 elsif data_line(1..1) = "."  then
    --&KJW 21-jul-85   data_line := " " & data_line(1..79) ;
    --&KJW 21-jul-85   eol := eol + 1 ;
    --&KJW 21-jul-85 end if ;
    --&KJW 21-jul-85 send_string(data_line(1..eol)) ;
    if data_line(1) = '.' then
      eof := eol = 1 ;
      if eof then
        --&KJW 23-jul-85 put_line("End of file found") ;
        send_string(".") ;
      else
        send_string("." & data_line(1..eol)) ;
      end if ;
    else
      send_string(data_line(1..eol)) ;
    end if ;
  end loop ;
  get_reply(reply) ;
  if reply(1..3) /= data_ok then
    put_line ("server could not deliver") ;
  end if ;
end if ;
exception
  when others =>
    put_line("exception in send_text") ;
    raise ;
end  send_text ;
end usmtp_text ;
--::::::::::::::
--uutils.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01233-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         uutils.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
-------------------------------------------------------------------------------
--
-- USMTP globals
--
package usmtp_utils is
  -- abnormal conditions:
  abort_usmtp : exception ;       -- user requests exit
  smtp_error  : exception ;       -- server sends error code (4xx or 5xx)
  unexpected_reply : exception ;  -- server sends insane reply
  tcp_reset   : exception ;       -- tcp resets connection
  -- implementation constraints
  max_line_len : constant integer := 80 ;
-- the following are the known replies to usmtp
open_ok      : constant string(1..3) := "220" ;
data_ok      : constant string(1..3) := "250" ;
send_data_ok : constant string(1..3) := "354" ;
rcpt_ok      : constant string(1..3) := "250" ;
will_forward : constant string(1..3) := "251" ;
helo_ok      : constant string(1..3) := "250" ;
quit_ok      : constant string(1..3) := "221" ;
end usmtp_utils ;
package body usmtp_utils is
end usmtp_utils ;
--::::::::::::::
--xhost.txt
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00010-200       80-01234-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         xhost.txt       Author : Paul Higgins
--
-----------------------------------------------------------------------
with buffer_data ;      -- to import address type
package xhost is
--
-- Utilities to translate host names to host addresses
-- Only TCP format addresses supported
-- could add some table maintainence procedures here if desired
--
procedure translate_host_name_to_address
--
-- Look up the host name in the table and return the address.
--
   (host_name    :  in string ;
    host_id      : out buffer_data.thirtytwo_bits ;  -- an internet address
    host_name_ok : out boolean ) ;
end ;
with text_io ;       use text_io ;
with usmtp_utils ;   use usmtp_utils ;
with buffer_data ;   use buffer_data ;  -- for type thirtytwo_bits
package body xhost is
type name_id_pair is record
  name : string (1..80) ;
  id   : buffer_data.thirtytwo_bits ;
end record ;
--&KJW 16-jul-85 a_blank_line : string (1..80) := ( others => ' ' ) ;
a_blank_line : string (1..80) ;    --&KJW 16-jul-85
a_name : string (1..80) ;
an_id  : thirtytwo_bits ;
--&KJW 16-jul-85 host_name_table : array (1..10) of name_id_pair :=
--&KJW 16-jul-85     ( others => (a_blank_line, 0) ) ;
host_name_table : array (1..10) of name_id_pair ;    --&KJW 16-jul-85
number_of_hosts : integer range 1..10 ;
procedure translate_host_name_to_address
--
-- Look up the host name in the table and return the address.
--
   (host_name    :  in string ;
    host_id      : out thirtytwo_bits ;
    host_name_ok : out boolean ) is
begin
host_name_ok := false ;
a_name := a_blank_line ;
a_name(1..host_name'length) := host_name ;
for i in 1..number_of_hosts loop
  if a_name = host_name_table(i).name then
    host_id := host_name_table(i).id ;
    host_name_ok := true ;
    exit ;
    end if ;
end loop ;
exception
  when others =>
    put_line("EXCEPTION IN TRANSLATE_HOST_NAME") ;
    raise ;
end ;
begin
for char in 1..80 loop        --&KJW 16-jul-85
  a_blank_line(char) := ' ';    --&KJW 16-jul-85
end loop;            --&KJW 16-jul-85
for host in 1..10 loop                --&KJW 16-jul-85
  host_name_table(host) := (a_blank_line, 0);    --&KJW 16-jul-85
end loop;                    --&KJW 16-jul-85
a_name := a_blank_line ;
a_name(1..6) := "saturn" ;
an_id :=  1 ;
host_name_table (1) := (a_name, an_id) ;
a_name := a_blank_line ;
a_name(1..4) := "mars" ;
an_id := 2 ;
host_name_table (2) := (a_name, an_id) ;
a_name := a_blank_line ;
a_name(1..5) := "wicat" ;
an_id := 3 ;
host_name_table (3) := (a_name, an_id) ;
number_of_hosts := 3 ;
end xhost ;