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

Text File | 1988-05-03 | 267.0 KB | 6,841 lines

--::::::::::::::
--debugio_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01053-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         DEBUGIO_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : debugio    Author : Mike Thomas

--   5/4/85  2:09 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--  5/21/85  1:40 PM : MODIFIED TO RECOMPILE UNDER TELESOFT ADA
--                     OLD CODE (DEC) MARKED AS --&MT

--  5/22/85  8:10 AM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT
WITH SYSTEM ;
USE  SYSTEM ;
PACKAGE debug_io IS

-- ****************************************************************************
--
-- This package has routines which do output to the CRT or a debug disk file
-- or both (or neither).  The interface is indended to look similer to
-- text_io for string, character and integer output.  NOTE : The Wicat
-- must close a disk file for it to exist.
--
-- ****************************************************************************


  --&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 ;


  PROCEDURE put (item : IN CHARACTER) ;

  PROCEDURE put (item : IN STRING) ;

  PROCEDURE put (item : IN bit_count_16_type) ;

--&MT--PROCEDURE put (item : IN SYSTEM.BYTE) ;      -- TeleLie-ADA flags this as an
--&MT                                               -- illegel redeclaration!
--&MT  PROCEDURE put_byte (item : IN SYSTEM.BYTE) ; -- so... use this
  PROCEDURE put_byte (item : IN bit_count_8_type) ;

  PROCEDURE put_line (item : IN CHARACTER) ;

  PROCEDURE put_line (item : IN STRING) ;

  PROCEDURE put_line (item : IN bit_count_16_type) ;

--&MT--PROCEDURE put_line (item : IN SYSTEM.BYTE) ; -- as above...

  PROCEDURE put_line_byte (item : IN bit_count_8_type) ;

  PROCEDURE open_debug_disk_file ;

  PROCEDURE close_debug_disk_file ;

  FUNCTION debug_disk_file_is_open RETURN BOOLEAN ;

-- user could store existing destination, set his own temporary one, and
-- restore the origional destination at any point to redirect debug info.
-- NOTE : ATTEMPTING TO WRITE TO THE DISK FILE WHEN IT IS NOT OPEN IS ERRONEOUS.

  TYPE debug_destination_type IS
   (none, crt_only, debug_disk_file_only, crt_and_disk) ;
  destination : debug_destination_type := none ;

END debug_io ;

--::::::::::::::
--debugio.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01054-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         DEBUGIO.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : debugio    Author : Mike Thomas

--   5/4/85  2:09 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--  5/21/85  1:40 PM : MODIFIED TO RECOMPILE UNDER TELESOFT ADA
--                     OLD CODE (DEC) MARKED AS --&MT

--  5/22/85  8:10 AM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

WITH TEXT_IO ;
USE  TEXT_IO ;

PACKAGE BODY debug_io IS

-- ****************************************************************************
--
-- It would be nice to revamp this package and use generics when they are
-- supported by the compiler.  Also could add enumerated type I/O routines.
-- If input routines are needed, they could be added.
-- ****************************************************************************

  debug_filename              : CONSTANT STRING(1..13) := "DEBUGFILE.TXT" ;
  debug_output_file           : TEXT_IO.FILE_TYPE ;
  output_file                 : TEXT_IO.FILE_MODE := TEXT_IO.OUT_FILE ;
  the_debug_disk_file_is_open : BOOLEAN := FALSE ;
--&MT  next line not used for TeleSoft
  PACKAGE integer_io IS NEW TEXT_IO.INTEGER_IO(bit_count_16_type) ;

  PROCEDURE screening_put (item : IN CHARACTER) IS
            -------------
  BEGIN
    IF item = ASCII.CR THEN
      TEXT_IO.PUT("<CR>") ; -- display logical cr so won't mess up printer
    ELSE
      TEXT_IO.PUT(item) ;
    END IF ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.SCR_PUT(C)") ;
      RAISE ;
  END screening_put ;


  PROCEDURE screening_put
            -------------
   (debug_file : IN TEXT_IO.FILE_TYPE ;
    item       : IN CHARACTER) IS
  BEGIN
    IF item = ASCII.CR THEN
      TEXT_IO.PUT(debug_file, "<CR>") ; -- display logical cr so won't
    ELSE
      TEXT_IO.PUT(debug_file, item) ;
    END IF ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.SCR_PUT(F,C)") ;
      RAISE ;
  END screening_put ;


  PROCEDURE put (item : IN CHARACTER) IS
  BEGIN
    CASE destination IS
      WHEN crt_only =>
        screening_put(item) ;
      WHEN debug_disk_file_only =>
        screening_put(debug_output_file, item) ;
      WHEN crt_and_disk =>
        screening_put(item) ;
        screening_put(debug_output_file, item) ;
      WHEN none =>
        NULL ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(C)") ;
      RAISE ;
  END put ;


  PROCEDURE put (item : IN STRING) IS
    buf : STRING (1..4*item'length) ;-- arbitrary length(allow for "expansion")

    buf_ptr : bit_count_32_type RANGE 0..4*item'length := 0 ;
--&MT    buf_ptr : bit_count_16_type RANGE 0..4*item'length := 0 ;

  BEGIN
  -- Calls to text_io are expensive, do processing here to reduce calls
  -- by printing strings and not individual characters.
    IF destination = none THEN RETURN ; END IF ;
    FOR index IN item'RANGE LOOP -- check for printer control char
      IF item(index) = ASCII.CR THEN -- replace ASCII.CR with "<CR>"
        buf((buf_ptr + 1)..(buf_ptr + 4)) := "<CR>" ;
        buf_ptr := buf_ptr + 4 ;
      ELSE
        buf_ptr := buf_ptr + 1 ;
        buf(buf_ptr) := item(index) ;
      END IF ;
    END LOOP ;
    IF buf_ptr > 0 THEN
      DECLARE -- handle strings > 132 so text_io does not get constraint error

        start : bit_count_32_type := 1 ;
        stop  : bit_count_32_type := 79 ;
        --&MT       start : bit_count_16_type := 1 ;
        --&MT       stop  : bit_count_16_type := 79 ;
      BEGIN
        LOOP
          IF stop > buf_ptr THEN
            CASE destination IS
              WHEN crt_only =>
                TEXT_IO.PUT(buf(start..buf_ptr)) ;
              WHEN debug_disk_file_only =>
                TEXT_IO.PUT(debug_output_file, buf(start..buf_ptr)) ;
              WHEN crt_and_disk =>
                TEXT_IO.PUT(buf(start..buf_ptr)) ;
                TEXT_IO.PUT(debug_output_file, buf(start..buf_ptr)) ;
              WHEN none =>
                NULL ;
              END CASE ;
              EXIT ;
          ELSE
            CASE destination IS
              WHEN crt_only =>
                TEXT_IO.PUT_LINE(buf(start..stop)) ;
              WHEN debug_disk_file_only =>
                TEXT_IO.PUT_LINE(debug_output_file, buf(start..stop)) ;
              WHEN crt_and_disk =>
                TEXT_IO.PUT_LINE(buf(start..stop)) ;
                TEXT_IO.PUT_LINE(debug_output_file, buf(start..stop)) ;
              WHEN none =>
                NULL ;
              END CASE ;
              start := start + 79;
              stop := stop + 79 ;
          END IF ; -- < 79 characters ?
        END LOOP ;
      END ; -- declare
    END IF ; -- buf_ptr > 0
  EXCEPTION
    WHEN OTHERS =>
      TEXT_IO.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(S)") ;
      RAISE ;
  END put ;


  PROCEDURE put (item : IN bit_count_16_type) IS
  BEGIN
    CASE destination IS
      WHEN crt_only =>
        INTEGER_IO.PUT(item) ;
      WHEN debug_disk_file_only =>
        INTEGER_IO.PUT(debug_output_file, item) ;
      WHEN crt_and_disk =>
        INTEGER_IO.PUT(item) ;
        INTEGER_IO.PUT(debug_output_file, item) ;
      WHEN none =>
        NULL ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(I)") ;
      RAISE ;
  END put ;


  PROCEDURE put_byte (item : IN bit_count_8_type) IS
  BEGIN
    debug_io.put('<') ;
    debug_io.put(bit_count_16_type(item)) ;
    debug_io.put('>') ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT(B)") ;
      RAISE ;
  END put_byte ;


  PROCEDURE put_line (item : IN CHARACTER) IS
  BEGIN
    debug_io.put(item) ;
    CASE destination IS
      WHEN crt_only =>
        TEXT_IO.NEW_LINE ;
      WHEN debug_disk_file_only =>
        TEXT_IO.NEW_LINE(debug_output_file) ;
      WHEN crt_and_disk =>
        TEXT_IO.NEW_LINE ;
        TEXT_IO.NEW_LINE(debug_output_file) ;
      WHEN none =>
        NULL ;
     END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(C)") ;
      RAISE ;
  END put_line ;


  PROCEDURE put_line (item : IN STRING) IS
  BEGIN
    IF destination = none THEN RETURN ; END IF ;
    debug_io.put(item) ;
    CASE destination IS
      WHEN crt_only =>
        TEXT_IO.NEW_LINE ;
      WHEN debug_disk_file_only =>
        TEXT_IO.NEW_LINE(debug_output_file) ;
      WHEN crt_and_disk =>
        TEXT_IO.NEW_LINE ;
        TEXT_IO.NEW_LINE(debug_output_file) ;
      WHEN none =>
        NULL ;
     END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      TEXT_IO.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(S)") ;
      RAISE ;
  END put_line ;


  PROCEDURE put_line (item : IN bit_count_16_type) IS
  BEGIN
    CASE destination IS
      WHEN crt_only =>
        INTEGER_IO.PUT(item) ;
        TEXT_IO.NEW_LINE ;
      WHEN debug_disk_file_only =>
        INTEGER_IO.PUT(debug_output_file, item) ;
        TEXT_IO.NEW_LINE(debug_output_file) ;
      WHEN crt_and_disk =>
        INTEGER_IO.PUT(item) ;
        INTEGER_IO.PUT(debug_output_file, item) ;
        TEXT_IO.NEW_LINE ;
        TEXT_IO.NEW_LINE(debug_output_file) ;
      WHEN none =>
        NULL ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(I)") ;
      RAISE ;
  END put_line ;


  PROCEDURE put_line_byte (item : IN bit_count_8_type) IS
  BEGIN
    debug_io.put('<') ;
    debug_io.put(bit_count_16_type(item)) ;
    debug_io.put_line('>') ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.PUT_LINE(B)") ;
      RAISE ;
  END put_line_byte ;


  PROCEDURE open_debug_disk_file IS
  BEGIN
    TEXT_IO.CREATE (debug_output_file, output_file, debug_filename) ;
    the_debug_disk_file_is_open := TRUE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.OPEN_DDF") ;
      RAISE ;
  END open_debug_disk_file ;


  PROCEDURE close_debug_disk_file IS
  BEGIN
    TEXT_IO.CLOSE(debug_output_file) ;
    the_debug_disk_file_is_open := FALSE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN DEBUG_IO.CLOSE_DDF") ;
      RAISE ;
  END close_debug_disk_file ;


  FUNCTION debug_disk_file_is_open RETURN BOOLEAN IS
  BEGIN
    RETURN the_debug_disk_file_is_open ;
  END debug_disk_file_is_open ;


BEGIN -- package body
  NULL ;
EXCEPTION
  WHEN OTHERS =>
    debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN debugio instantiation") ;
    RAISE ;
END debug_io ;
--::::::::::::::
--pvirtmpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01063-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         PVIRTMPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File pvirtmpac     AUTHOR : Paul Higgins

--   5/4/85  2:09 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

WITH SYSTEM ; -- to access system.byte

PACKAGE virtual_terminal -- specification
        ----------------
 IS

--**********************  USER SPECIFICATION  *******************************
--
-- This package implements the interface between telnet and the process
--  using telnet. The interface is on a character by character basis and
--  is buffered. The "user process" is referred to as the NVT (network
--  virtual terminal) and could be an applications process (FTP,SMTP,etc)
--  or a terminal-handler.
--
-------------------------  data specifications  -----------------------------


--&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 ;

  SUBTYPE port_number IS bit_count_16_type ;

  ---------------------  procedure specifications  ----------------------------

--- telnet's side of the interface:

  FUNCTION there_are_characters_in_keyboard_buffer (I : port_number)
           ---------------------------------------
   RETURN BOOLEAN ;

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This function returns true if there are unprocessed characters in the
  -- NVT keyboard buffer.
  -------------------------------------------------------------------------



  PROCEDURE get_next_character_from_keyboard_buffer
            ---------------------------------------
   (I   : IN  port_number;
   char : OUT bit_count_8_type) ;

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This procedure will return the next unprocessed character from the
  -- NVT keyboard buffer.
  -------------------------------------------------------------------------



  FUNCTION there_is_room_in_the_printer_buffer (I : port_number)
           -----------------------------------
   RETURN BOOLEAN ;

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This function returns true if there is room for a character in the
  -- NVT printer buffer.
  -------------------------------------------------------------------------



  PROCEDURE output_character_to_NVT_printer
            -------------------------------
   (I   : IN port_number;
   char : IN bit_count_8_type);

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This procedure will output a character to the NVT printer buffer.
  -- If there is no room in the buffer the character will be lost.
  -- It is the caller's responsibility to make sure there is room in the
  -- buffer.
  -------------------------------------------------------------------------


  --- nvt's side of the interface

  FUNCTION there_are_characters_in_printer_buffer (I : port_number)
           ---------------------------------------
   RETURN BOOLEAN ;

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This function returns true if there are unprocessed characters in the
  -- NVT printer buffer.
  -------------------------------------------------------------------------



  PROCEDURE get_next_character_from_telnet
            ------------------------------
   (I : port_number;
   char : OUT bit_count_8_type) ;

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This procedure will return the next unprocessed character from the
  -- NVT printer buffer.
  -------------------------------------------------------------------------



  FUNCTION there_is_room_in_the_keyboard_buffer (I : port_number)
           -----------------------------------
   RETURN BOOLEAN ;

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- This function returns true if there is room for a character in the
  -- NVT keyboard buffer.
  -------------------------------------------------------------------------



  PROCEDURE send_char_to_telnet
            -------------------
   (I :   IN port_number;
   char : IN bit_count_8_type);

  -- ***********************  USER SPECIFICATION  *************************
  --
  -- If there is no room in the buffer the character will be lost.
  -- It is the caller's responsibility to make sure there is room in the
  -- buffer.
  -------------------------------------------------------------------------


END virtual_terminal ;
--::::::::::::::
--pvirtmpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01064-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         PVIRTMPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File pvirtmpac    AUTHOR : Paul Higgins

--   5/4/85  2:09 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

with text_io; use text_io ;

PACKAGE BODY virtual_terminal IS
             ----------------

-- *************************  BODY SPECIFICATION  *****************************
--
-- This package manages buffers which are tied to the process/user terminal
-- "I/O" device.  For example, keyboard input is stored in the keyboard_
-- input_buffer.  Then, the Presentation Protocol Layer can retrieve
-- characters from that buffer and pass them back to the Application Protocol
-- Layer when that layer asks for the characters.  Similar processing
-- occurs for the printer_output_buffer.  The APL could ask the PPL to send
-- a character out to the NVT_printer; the PPL would put the character into
-- the printer_output_buffer and this character would eventually be
-- "printed" on the nvt printer.  Also procedures exist to store and retrieve
-- these buffers in their entirety.
--
-- ****************************************************************************

  -- the buffers

  buffer_length : CONSTANT bit_count_16_type := 256 ; -- arbitrary
  SUBTYPE buf_ptr IS bit_count_16_type RANGE 0..buffer_length ;
  TYPE buffer_type IS ARRAY (0..buffer_length-1) OF bit_count_8_type ;

  -- keyboard input buffer

  TYPE keyboard_input_buffer_record IS
    RECORD
      buffer  : buffer_type ;
      in_ptr  : buf_ptr := 0 ;
      out_ptr  : buf_ptr := 0 ;
    END RECORD ;


  -- printer output buffer

  TYPE printer_output_buffer_record IS
    RECORD
      buffer   : buffer_type ;
      in_ptr   : buf_ptr := 0 ;
      out_ptr  : buf_ptr := 0 ;
    END RECORD ;


  TYPE nvt_ppl_buffers_type IS
    RECORD
      keyboard_buffer : keyboard_input_buffer_record ;
      printer_buffer : printer_output_buffer_record ;
    END RECORD ;


 number_of_devices : CONSTANT port_number := 1 ;

 io_buffer : ARRAY (1..number_of_devices) OF nvt_ppl_buffers_type ;


-- Note that only one task is implemented. This should be a task type,
-- and an array of them should be defined (one for each device).
-- This could not be done by TS for now...

TASK inbuf IS
  ENTRY kbd_char_rdy     (device : IN port_number; rdy : OUT BOOLEAN ) ;
  ENTRY get_kbd_char     (device : IN port_number; ch  : OUT bit_count_8_type) ;
  ENTRY put_kbd_char     (device : IN port_number; ch  : IN  bit_count_8_type) ;
  ENTRY get_printer_char (device : IN port_number; ch  : OUT bit_count_8_type) ;
  ENTRY put_printer_char (device : IN port_number; ch  : IN  bit_count_8_type) ;
  ENTRY printer_char_rdy (device : IN port_number; rdy : OUT BOOLEAN ) ;
END ;


TASK BODY inbuf IS
  BEGIN
  LOOP
  SELECT
    ACCEPT kbd_char_rdy     (device : IN port_number; rdy : OUT BOOLEAN )
      DO
        rdy := io_buffer(device).keyboard_buffer.in_ptr
              /= io_buffer(device).keyboard_buffer.out_ptr ;
      END ;
  OR
    WHEN io_buffer(1).keyboard_buffer.in_ptr
              /= io_buffer(1).keyboard_buffer.out_ptr =>
      ACCEPT get_kbd_char (device : IN port_number; ch  : OUT bit_count_8_type)
        DO
          ch := io_buffer(device).keyboard_buffer.buffer
                (io_buffer(device).keyboard_buffer.out_ptr) ;
          io_buffer(device).keyboard_buffer.out_ptr :=
           (io_buffer(device).keyboard_buffer.out_ptr + 1) mod buffer_length ;
        END ;
  OR
    ACCEPT put_kbd_char (device : IN port_number; ch  : IN  bit_count_8_type)
      DO
        IF io_buffer(device).keyboard_buffer.out_ptr
              /= (io_buffer(device).keyboard_buffer.in_ptr + 1)
                mod buffer_length THEN
        io_buffer(device).keyboard_buffer.buffer
               (io_buffer(device).keyboard_buffer.in_ptr) := ch ;
        io_buffer(device).keyboard_buffer.in_ptr :=
             (io_buffer(device).keyboard_buffer.in_ptr + 1) mod buffer_length ;
        END IF ;
     END ;
  OR
    WHEN io_buffer(1).printer_buffer.in_ptr
              /= io_buffer(1).printer_buffer.out_ptr =>
      ACCEPT get_printer_char(device : IN port_number; ch : OUT bit_count_8_type)
        DO
          ch := io_buffer(device).printer_buffer.buffer
                (io_buffer(device).printer_buffer.out_ptr) ;
          io_buffer(device).printer_buffer.out_ptr :=
              (io_buffer(device).printer_buffer.out_ptr + 1) mod buffer_length ;
        END ;
  OR
    ACCEPT put_printer_char(device : IN port_number; ch : IN bit_count_8_type)
      DO
        IF io_buffer(device).printer_buffer.out_ptr
              /= (io_buffer(device).printer_buffer.in_ptr + 1)
                mod buffer_length THEN
        io_buffer(device).printer_buffer.buffer
               (io_buffer(device).printer_buffer.in_ptr) := ch ;
        io_buffer(device).printer_buffer.in_ptr :=
             (io_buffer(device).printer_buffer.in_ptr + 1) mod buffer_length ;
        END IF ;
     END ;
   OR
    ACCEPT printer_char_rdy(device : IN port_number; rdy : OUT BOOLEAN )
      DO
        rdy := io_buffer(device).printer_buffer.in_ptr
              /= io_buffer(device).printer_buffer.out_ptr ;
      END ;
  END SELECT ;
  END LOOP ;
END ;



  FUNCTION there_are_characters_in_keyboard_buffer (I : port_number)
           ---------------------------------------
   RETURN BOOLEAN is

  flag : boolean ;
  begin
    inbuf.kbd_char_rdy(i, flag) ;
    RETURN flag ;
  END there_are_characters_in_keyboard_buffer ; -- body





  PROCEDURE get_next_character_from_keyboard_buffer
            ---------------------------------------
   (I   : IN  port_number;
   char : OUT bit_count_8_type) is
  BEGIN
    char := 0 ; -- default value
    inbuf.get_kbd_char(i, char) ;
  END get_next_character_from_keyboard_buffer ; -- body




  FUNCTION there_is_room_in_the_printer_buffer (I : port_number)
           -----------------------------------
   RETURN BOOLEAN IS

  -- ***********************  BODY SPECIFICATION  *************************
  --
  -- This function returns true if there is room for a character in the
  -- NVT printer buffer.
  -------------------------------------------------------------------------
  BEGIN
    RETURN TRUE ;
  END there_is_room_in_the_printer_buffer ; -- body



  PROCEDURE output_character_to_NVT_printer
            -------------------------------
   (I   : IN port_number;
   char : IN bit_count_8_type ) is

  BEGIN
  inbuf.put_printer_char(i,char) ;
  END output_character_to_NVT_printer ; -- body


  FUNCTION there_are_characters_in_printer_buffer (I : port_number)
           ---------------------------------------
   RETURN BOOLEAN is
    flag : boolean ;
    begin
    inbuf.printer_char_rdy(i, flag) ;
    RETURN flag ;
    END ;


  PROCEDURE get_next_character_from_telnet
            ------------------------------
   (I : port_number;
   char : OUT bit_count_8_type) is
    begin
    char := 0 ;
    inbuf.get_printer_char(i, char) ;
    end ;

  PROCEDURE send_char_to_telnet
            -------------------
   (I :   IN port_number;
   char : IN bit_count_8_type ) is
    begin
      inbuf.put_kbd_char(i, char) ;
    end ;


  FUNCTION there_is_room_in_the_keyboard_buffer (I : port_number)
           -----------------------------------
   RETURN BOOLEAN IS
  BEGIN
    RETURN TRUE ;
  END there_is_room_in_the_keyboard_buffer ; -- body



  BEGIN
    NULL ;
  END virtual_terminal ; -- package body

--::::::::::::::
--dec_tn_tasks_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01055-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         DEC_TN_TASKS_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- authors : Mike Thomas, Paul Higgins
-- file : tn_tasks


--  6/13/85   8:30 PM : tasks mod to allow telnet to while hang on vax
--  6/25/85   3:06 PM : tcp_reader remove stop entry

WITH with_ulp_communicate ;
PACKAGE dec_tn_tasks IS

------------------------ tasks for Dec Ada Vax version -------------------------

  TASK tn IS
    PRAGMA PRIORITY(10) ;
    ENTRY go ;
    ENTRY wait ;
  END tn ; -- ok to put name here? --TBD


  TASK telnet_buffer IS
    PRAGMA PRIORITY(9) ;
    ENTRY put_tcp_message(tcp_message : IN  with_ulp_communicate.user_message) ;
    ENTRY get_tcp_message(tcp_message : OUT with_ulp_communicate.user_message) ;
    ENTRY tcp_message_ready(buf_not_empty : OUT BOOLEAN) ;
  END telnet_buffer ;


  TASK tcp_reader IS
    PRAGMA PRIORITY(8) ;
    ENTRY start ;
  END tcp_reader ;


END dec_tn_tasks ;

--::::::::::::::
--ttyio_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01069-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         TTYIO_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File ttyio    AUTHOR : Paul Higgins

--   5/4/85  2:09 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

package iotasks is
  task getchar IS
   PRAGMA PRIORITY(6) ; -- try to lower it to keep it from hanging
  end getchar;
  task putchar IS
   PRAGMA PRIORITY(8) ; -- whole telnet program
  end putchar;
end  iotasks ;

--::::::::::::::
--ttyio.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01070-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         TTYIO.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : ttyio    Author : Paul Higgins

--   5/4/85  2:09 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT
--  6/11/85  4:00 PM : modified for DEC Ada by Paul Higgins
--  6/14/85  3:28 PM : dec telnet tasking mod (MT)


with text_io ; use text_io ;
with virtual_terminal; use virtual_terminal;
with system ;
with dec_tn_tasks ;

package body iotasks 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 ;

task body getchar is
  a_char : character ;
  a_var  : bit_count_8_type ;
  cr     : bit_count_8_type := 13 ; -- ASCII.CR
  len    : integer ;
  a_str  : string (1..255) ;
begin
  loop
    IF TEXT_IO.END_OF_LINE THEN
      send_char_to_telnet(1,cr) ; -- text_io will not read in a ascii.cr
      TEXT_IO.SKIP_LINE ; -- hop past end of line
    ELSE
      --TEL text_io.get(a_char) ;
      --TEL a_var := character'pos(a_char) ;
      --TEL send_char_to_telnet(1,a_var) ;
      --&MT vax version:
      text_io.get_line(a_str,len) ;
      for i in 1..len loop
        a_var := character'pos(a_str(i)) ;
        send_char_to_telnet(1,a_var) ;
     end loop ; --&MT vax
     send_char_to_telnet(1,cr) ; -- replace cr stripped out by text_io.
    END IF ;
    dec_tn_tasks.tn.go ; -- signal telnet controller that there is input
  end loop ;
end getchar ;

task body putchar is
  a_char : character ;
  a_var  : bit_count_8_type ;
begin
  loop
    get_next_character_from_telnet(1,a_var) ;
    IF bit_count_16_type(a_var) = 13 THEN -- CR ==> new line
      TEXT_IO.NEW_LINE ; -- text_io will send cr lf
    ELSE
      a_char := character'val(a_var) ;
      text_io.put(a_char) ;
    END IF ;
  end loop ;
end putchar ;

end iotasks ;
--::::::::::::::
--auserdpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01051-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         AUSERDPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------


-- File : auserdpac   Author : Mike Thomas

--   5/6/85  3:40 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--   5/21/85 3:55 PM : MODIFY FOR TELESOFT
--                     OLD CODE (DEC) MARKED AS --&MT

--   5/22/85 9:20 AM : MODIFY FOR DEC ADA
--                     OLD CODE MARKED AS --&MT
--   6/11/85 5:14 PM : lcn changed from lcn_type to lcn_ptr_type
--   6/23/85 9:38 PM : init ga_state to no go_ahead_sent

--&MT PRAGMA SOURCE_INFO(ON) ; -- ask TeleSoft to provide run-time error reports
WITH SYSTEM ;
WITH virtual_terminal ;
WITH with_ulp_communicate ; -- access lcn_type
WITH buffer_data ; -- access sixteen_bits type

PACKAGE user_data -- specification
        ---------
 IS

-- **********************  USER SPECIFICATION  ********************************
--
-- This package contains the user buffers
-- and state information.  The state information types and the maximum
-- user command length are also exported.
--
-- ****************************************************************************

  -----------------------  data (object) declarations  -----------------------

  --&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 ;

  -- state information maintained for each user
  TYPE nvt_io_state_type IS (io_done, no_io_done) ;
  TYPE communication_state_type IS (connection_established,
                                    no_connection_established) ;
  TYPE command_state_type IS (partial_command, no_partial_command) ;
  TYPE go_ahead_sent_state_type IS (go_ahead_sent, no_go_ahead_sent) ;

  -- maximum user command string length (might use in partial cmd)
  max_cmd_length : CONSTANT bit_count_16_type := 80 ; -- arbitrary, make defered constant when supported
  TYPE string_type IS ARRAY (bit_count_16_type RANGE <>) OF bit_count_8_type ;
  max_out_string : CONSTANT bit_count_16_type := 256 ; -- largest ucb buffer size
  SUBTYPE out_string_type IS string_type(1..max_out_string) ;

  -- buffer space maintained for each user

  SUBTYPE partial_command_buf_length IS
   bit_count_16_type RANGE 0..max_cmd_length ;
  TYPE partial_cmd_buffer_type IS
   ARRAY (1..max_cmd_length) OF bit_count_8_type ;
  TYPE partial_command_buffer_type IS
    RECORD
      buffer : partial_cmd_buffer_type ;
      length : partial_command_buf_length := 0 ;
    END RECORD ;

  data_buffer_length   : CONSTANT bit_count_16_type := 100 ; -- arbitrary
  SUBTYPE data_buf_ptr IS bit_count_16_type RANGE 0..data_buffer_length - 1 ;
  TYPE data_buf_type IS ARRAY (0..data_buffer_length - 1) OF bit_count_8_type ;
  TYPE data_buffer_type IS
    RECORD
      buffer : data_buf_type ;
      buf_head : data_buf_ptr := 0 ;
      buf_tail : data_buf_ptr := 1 ;
    END RECORD ;
-------------------------------  option tables  -------------------------------
  TYPE option_type IS (echo,suppress_ga) ; -- list of all options currently supported
  number_of_options_supported : CONSTANT bit_count_16_type := 2 ;
  TYPE option_array_type IS ARRAY (1..number_of_options_supported)
   OF option_type ;
  SUBTYPE option_count_type IS bit_count_16_type
   RANGE 0..number_of_options_supported ;

  TYPE option_table_type IS
    RECORD
      option          : option_array_type ;
      number_of_items : option_count_type := 0 ;
    END RECORD ;

  TYPE option_tables_type IS
    RECORD
      local_options_desired    : option_table_type ;
      local_options_pending    : option_table_type ;
      local_options_in_effect  : option_table_type ;
      remote_options_desired   : option_table_type ;
      remote_options_pending   : option_table_type ;
      remote_options_in_effect : option_table_type ;
    END RECORD ;

-- These structures contain buffers which are used to communicate with the
-- transport level.  The trans_input_buffer and trans_output_buffer are
-- tightly coupled to the transport level and contain both messages and data.
-- (after link-up to TCP these debug buffers will not be used)
-- The other buffers are loosely coupled and have exclusivly data or messages.
--
-- ****************************************************************************

  -- transport level input buffer containing messages and data
  -- direct channel to TCP (actual form will change) -- this for debug

--MT  trans_in_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary
--MT  SUBTYPE trans_in_buf_ptr IS bit_count_16_type
--MT   RANGE 0..trans_in_buffer_length - 1 ;
--MT  TYPE trans_input_buffer_type IS ARRAY (0..trans_in_buffer_length - 1)
--MT   OF bit_count_8_type ;
--MT  TYPE trans_input_buffer_record IS
--MT    RECORD
--MT      buffer : trans_input_buffer_type ;
--MT      buf_head : trans_in_buf_ptr := 0 ;
--MT      buf_tail : trans_in_buf_ptr := 1 ;
--MT    END RECORD ;


  -- transport level output buffer containing messages and data
  -- direct channel to TCP (actual form will change) -- this for debug

--MT  trans_out_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary
--MT  SUBTYPE trans_out_buf_length IS bit_count_16_type RANGE 0..trans_out_buffer_length ;
--MT  TYPE trans_output_buffer_type IS ARRAY (1..trans_out_buffer_length)
--MT   OF bit_count_8_type ;
--MT  TYPE trans_output_buffer_record IS
--MT    RECORD
--MT      buffer : trans_output_buffer_type ;
--MT      length : trans_out_buf_length := 0 ;
--MT    END RECORD ;


  -- transport level to telnet messages
  -- these buffers not "directly" connected to the transport level

  trans_to_telnet_msg_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary
  SUBTYPE trans_to_telnet_msg_buf_ptr_type IS
   bit_count_16_type RANGE 0..trans_to_telnet_msg_buffer_length - 1 ;
  TYPE trans_to_telnet_msg_buffer_type IS
   ARRAY (0..trans_to_telnet_msg_buffer_length - 1) OF bit_count_8_type ;
  TYPE trans_to_telnet_messages_record IS
    RECORD
      buffer   : trans_to_telnet_msg_buffer_type ;
      buf_head : trans_to_telnet_msg_buf_ptr_type := 0 ;
      buf_tail : trans_to_telnet_msg_buf_ptr_type := 1 ;
    END RECORD ;


  -- transport level to telnet data
  -- these buffers not "directly" connected to the transport level

  trans_to_telnet_data_buffer_length : CONSTANT bit_count_16_type := 512 ; -- arbitrary
  SUBTYPE trans_to_telnet_data_buf_ptr_type IS
   bit_count_16_type RANGE 0..trans_to_telnet_data_buffer_length - 1 ;
  TYPE trans_to_telnet_data_buffer_type IS
   ARRAY (0..trans_to_telnet_data_buffer_length - 1) OF bit_count_8_type ;
  TYPE trans_to_telnet_data_record IS
    RECORD
      buffer   : trans_to_telnet_data_buffer_type ;
      buf_head : trans_to_telnet_data_buf_ptr_type := 0 ;
      buf_tail : trans_to_telnet_data_buf_ptr_type := 1 ;
    END RECORD ;


  TYPE ppl_trans_buffers_type IS
    RECORD
--MT      trans_input_buffer       : trans_input_buffer_record ; -- debug
--MT      trans_output_buffer      : trans_output_buffer_record ; -- debug

      trans_to_telnet_messages : trans_to_telnet_messages_record ;
      trans_to_telnet_data     : trans_to_telnet_data_record ;
    END RECORD ;

  TYPE control_block_type IS -- (contains state information etc. for a user)
    RECORD
      port                      : virtual_terminal.port_number ;
      tl_port_number            : buffer_data.sixteen_bits ; -- transport level local port #
      lcn                       : with_ulp_communicate.lcn_ptr_type ; -- TCP local_connection_number
      NVT_IO_state              : NVT_IO_state_type := IO_done ;
      communication_state       : communication_state_type :=
                                   no_connection_established ;
      command_state             : command_state_type := no_partial_command ;
      GA_state                  : go_ahead_sent_state_type := no_go_ahead_sent ;
      GA_received               : BOOLEAN := FALSE ;
      synch_is_in_progress      : BOOLEAN := FALSE ;
      last_keybd_char_was_cmd   : BOOLEAN := FALSE ;
      rcv_data_is_urgent        : BOOLEAN := FALSE ;
      last_data_char_rcv_not_cr : BOOLEAN := TRUE ;
      partial_command_buffer    : partial_command_buffer_type ;
      data_buffer               : data_buffer_type ;
      option_tables             : option_tables_type ;
      trans_buffers             : ppl_trans_buffers_type ;
    END RECORD ;

  user_control_block : control_block_type ;

  -------------------  end data (object) declarations  -----------------------

  ---------------  function/procedure (verb) specifications  -----------------

  -- partial command data buffer manipulation functions/procedures

  FUNCTION there_is_data_in_command_buffer -- specification
           -------------------------------
   RETURN BOOLEAN ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This function returns true if there is data in the APL command buffer.
  -----------------------------------------------------------------------------


  FUNCTION there_is_room_in_command_buffer -- specification
           -------------------------------
   RETURN BOOLEAN ; -- room for a character
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This function returns true if there is room for a character in the
  -- APL command buffer.
  -----------------------------------------------------------------------------


  PROCEDURE put_char_in_command_buffer -- specificaton
            --------------------------
   (char : IN bit_count_8_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure will add a character to the APL command buffer.  The
  -- user should make sure there is room in the buffer before calling this
  -- procedure.  If the NVT output buffer is full, the character will be lost.
  -----------------------------------------------------------------------------


  PROCEDURE put_string_in_command_buffer -- specificaton
            ----------------------------
   (str : IN string_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure will add characters to the APL command buffer.  If there
  -- is not enough room in the buffer for all the characters, then the
  -- extra characters will be lost.
  -----------------------------------------------------------------------------


  PROCEDURE get_char_from_command_buffer -- specificaton
            ----------------------------
   (char : OUT bit_count_8_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure returns the next character from the APL command buffer.
  -- The user should determine that there are characters in the buffer before
  -- calling this procedure.  If the buffer is empty, this procedure will
  -- return null.
  -----------------------------------------------------------------------------


  PROCEDURE get_command_buffer -- specificaton
            ------------------
   (buffer : OUT out_string_type ;
    length : OUT bit_count_16_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure returns the entire contents of the APL command buffer.
  -- The user should determine that there are characters in the buffer before
  -- calling this procedure.  If the buffer is empty, this procedure will
  -- return null.
  -----------------------------------------------------------------------------

  -- data buffer manipulation functions/procedures

  FUNCTION there_is_data_in_data_buffer -- specification
           ----------------------------
   RETURN BOOLEAN ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This function returns true if there is data in the APL data buffer.
  -----------------------------------------------------------------------------


  FUNCTION there_is_room_in_data_buffer -- specification
           ----------------------------
   RETURN BOOLEAN ; -- room for a character
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This function returns true if there is room for a character in the
  -- APL data buffer.
  -----------------------------------------------------------------------------


  PROCEDURE put_char_in_data_buffer -- specificaton
            -----------------------
   (char : IN bit_count_8_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure will add a character to the APL data buffer.  The
  -- user should make sure there is room in the buffer before calling this
  -- procedure.  If the NVT output buffer is full, the character will be lost.
  -----------------------------------------------------------------------------


  PROCEDURE put_string_in_data_buffer -- specificaton
            -------------------------
   (str : IN string_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure will add characters to the data buffer.  If there
  -- is not enough room in the buffer for all the characters, the
  -- excess characters will be lost.
  -----------------------------------------------------------------------------


  PROCEDURE get_char_from_data_buffer -- specificaton
            -------------------------
   (char : OUT bit_count_8_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure returns the next character from the APL data buffer.
  -- The user should determine that there are characters in the buffer before
  -- calling this procedure.  If the buffer is empty, this procedure will
  -- return null.
  -----------------------------------------------------------------------------


  PROCEDURE get_data_buffer -- specificaton
            ---------------
   (buffer : OUT out_string_type ;
    length : OUT bit_count_16_type) ;
  -- ***********************  USER SPECIFICATION  *****************************
  --
  -- This procedure returns the entire contents of the APL data buffer.
  -- The user should determine that there are characters in the buffer before
  -- calling this procedure.  If the buffer is empty, this procedure will
  -- return null.
  -----------------------------------------------------------------------------


  PROCEDURE get -- specification
            ---
   (user_control_block_out : OUT control_block_type) ;
    -- **********************  USER SPECIFICATION  ****************************
    --
    -- This procedure returns the contents of the entire user control block
    -- which contains state information and buffers for the TELNET user.
    -------------------------------------------------------------------------


  PROCEDURE put -- specification
            ---
   (user_control_block_in : IN control_block_type) ;
    -- **********************  USER SPECIFICATION  ****************************
    --
    -- This procedure assigns the contents of the entire user control block
    -- which contains state information and buffers for the TELNET user.
    -------------------------------------------------------------------------



    PROCEDURE reset_user_control_block ;
              ------------------------
    -- **********************  USER SPECIFICATION  ****************************
    --
    -- This procedure resets the user control block as a result of a connection
    -- closing due to abort or a normal close.
    ---------------------------------------------------------------------------


  -----------  end function/procedure (verb) specifications  -----------------

END user_data ; -- package specification

--::::::::::::::
--auserdpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01052-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         AUSERDPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------


-- File : auserdpac   Author : Mike Thomas

--    5/6/85   3:40 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--   5/21/85   3:55 PM : MODIFY FOR TELESOFT
--                     OLD CODE (DEC) MARKED AS --&MT

--   5/22/85   9:20 AM : MODIFY FOR DEC ADA
--                     OLD CODE MARKED AS --&MT
--   6/26/85  10:17 AM : reset ga_state to no_go_ahead_sent
--   7/20/85   4:32 PM : don't reset desired options table in reset procedure


WITH debug_io ;

PACKAGE BODY user_data
             ---------
 IS

  -- partial command data buffer manipulation functions/procedures

  FUNCTION there_is_data_in_command_buffer -- body
           -------------------------------
   RETURN BOOLEAN IS
  BEGIN
    RETURN user_control_block.partial_command_buffer.length /= 0 ;
  END there_is_data_in_command_buffer ; -- body


  FUNCTION there_is_room_in_command_buffer -- body -- room for a character
           -------------------------------
   RETURN BOOLEAN IS
  BEGIN
    RETURN user_control_block.partial_command_buffer.length < max_cmd_length ;
  END there_is_room_in_command_buffer ; -- body


  PROCEDURE put_char_in_command_buffer -- body
            --------------------------
   (char : IN bit_count_8_type) IS

    length : partial_command_buf_length RENAMES
     user_control_block.partial_command_buffer.length ;
    buffer : partial_cmd_buffer_type RENAMES
     user_control_block.partial_command_buffer.buffer ;

  BEGIN
    IF there_is_room_in_command_buffer THEN
      length := length + 1 ;
      buffer(length) := char ;
    END IF ;
  END put_char_in_command_buffer ; -- body


  PROCEDURE put_string_in_command_buffer -- body
            ----------------------------
   (str : IN string_type) IS
  BEGIN
    FOR index IN str'RANGE LOOP
      put_char_in_command_buffer(str(index)) ;
    END LOOP ;
  END put_string_in_command_buffer ; -- body


  PROCEDURE get_char_from_command_buffer -- body
            ----------------------------
   (char : OUT bit_count_8_type) IS

    length : partial_command_buf_length RENAMES
     user_control_block.partial_command_buffer.length ;
    buffer : partial_cmd_buffer_type RENAMES
     user_control_block.partial_command_buffer.buffer ;

  BEGIN
    char := 0 ;
    IF there_is_data_in_command_buffer THEN
      char := buffer(1) ;
      buffer(1..length - 1) := buffer(2..length) ;
      length := length - 1 ;
    END IF ;
  END get_char_from_command_buffer ; -- body


  PROCEDURE get_command_buffer -- body
            ------------------
   (buffer : OUT out_string_type ;
    length : OUT bit_count_16_type) IS

    cmd_length : partial_command_buf_length RENAMES
     user_control_block.partial_command_buffer.length ;
    cmd_buffer : partial_cmd_buffer_type RENAMES
     user_control_block.partial_command_buffer.buffer ;
    buffer_length : CONSTANT bit_count_16_type := cmd_length ;

  BEGIN
    length := cmd_length ;
    cmd_length := 0 ;
    FOR index IN 1..buffer_length LOOP
      buffer(index):= cmd_buffer(index) ;
    END LOOP ;
  END get_command_buffer ; -- body

  -- data buffer manipulation functions/procedures

  FUNCTION there_is_data_in_data_buffer -- body
           ----------------------------
   RETURN BOOLEAN IS
    data : data_buffer_type RENAMES user_control_block.data_buffer ;
  BEGIN
    RETURN (data.buf_head + 1) MOD data_buffer_length /= data.buf_tail ;
  END there_is_data_in_data_buffer ; -- body


  FUNCTION there_is_room_in_data_buffer -- body (room for a character)
           ----------------------------
   RETURN BOOLEAN IS
    data : data_buffer_type RENAMES user_control_block.data_buffer ;
  BEGIN
    RETURN data.buf_head /= data.buf_tail ;
  END there_is_room_in_data_buffer ; -- body


  PROCEDURE put_char_in_data_buffer -- body
            -----------------------
   (char : IN bit_count_8_type) IS
    data : data_buffer_type RENAMES user_control_block.data_buffer ;
  BEGIN
    IF there_is_room_in_data_buffer THEN
      data.buffer(data.buf_tail) := char ;
      data.buf_tail := (data.buf_tail + 1) MOD data_buffer_length ;
    END IF ;
  END put_char_in_data_buffer ; -- body


  PROCEDURE put_string_in_data_buffer -- body
            -------------------------
   (str : IN string_type) IS
  BEGIN
    FOR index IN str'RANGE LOOP
      put_char_in_data_buffer(str(index)) ;
    END LOOP ;
  END put_string_in_data_buffer ; -- body


  PROCEDURE get_char_from_data_buffer -- body
            -------------------------
   (char : OUT bit_count_8_type) IS
    data : data_buffer_type RENAMES user_control_block.data_buffer ;
  BEGIN
    char := 0 ;
    IF there_is_data_in_data_buffer THEN
      data.buf_head := (data.buf_head + 1) MOD data_buffer_length ;
      char := data.buffer(data.buf_head) ;
    END IF ;
  END get_char_from_data_buffer ; -- body


  PROCEDURE get_data_buffer -- body
            ---------------
   (buffer : OUT out_string_type ;
    length : OUT bit_count_16_type) IS
    data : data_buffer_type RENAMES user_control_block.data_buffer ;

    buffer_length : bit_count_16_type := 0 ;

  BEGIN
    WHILE (data.buf_head + 1) MOD data_buffer_length /= data.buf_tail LOOP
      data.buf_head := (data.buf_head + 1) MOD data_buffer_length ;
      buffer_length := buffer_length + 1 ;
      buffer(buffer_length) := data.buffer(data.buf_head) ;
    END LOOP ;
    length := buffer_length ;
  END get_data_buffer ; -- body



  PROCEDURE get -- body
            ---
   (user_control_block_out : OUT control_block_type) IS
  BEGIN
    user_control_block_out := user_control_block ;
  END get ; -- body


  PROCEDURE put -- body
            ---
   (user_control_block_in : IN control_block_type) IS
  BEGIN
    user_control_block := user_control_block_in ;
  END put ; -- body


  PROCEDURE reset_user_control_block IS
            ------------------------
    ucb : control_block_type RENAMES user_control_block ;
  BEGIN -- restore default values
    ucb.nvt_io_state                         := io_done ;
    ucb.communication_state                  := no_connection_established ;
    ucb.command_state                        := no_partial_command ;
    ucb.ga_state                             := no_go_ahead_sent ;
    ucb.ga_received                          := FALSE ;
    ucb.synch_is_in_progress                 := FALSE ;
    ucb.last_keybd_char_was_cmd              := FALSE ;
    ucb.rcv_data_is_urgent                   := FALSE ;
    ucb.last_data_char_rcv_not_cr            := TRUE ;
    ucb.partial_command_buffer.length        := 0 ;
    ucb.option_tables.local_options_pending.number_of_items    := 0 ;
    ucb.option_tables.local_options_in_effect.number_of_items  := 0 ;
    ucb.option_tables.remote_options_pending.number_of_items   := 0 ;
    ucb.option_tables.remote_options_in_effect.number_of_items := 0 ;
  END reset_user_control_block ;


BEGIN -- user_data
  NULL ;
EXCEPTION
  WHEN OTHERS =>
    debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN user_data instantiation") ;
    RAISE ;

END user_data ; -- package body
--::::::::::::::
--dec_tn_tasks.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01056-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         DEC_TN_TASKS.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------
-- FILE : DEC_TN_TASKS         AUTHOR MIKE THOMAS AND PAUL HIGGINS
--  6/17/85  4:46 PM : ADD TN.GO TO PUT_TCP_MESSAGE
--  6/25/85  2:50 PM : have tcp_reader stop reading on Rx of close (#18)
--  6/27/85  1:56 PM : ...and abort_ok(#8) and connection_reset(#16)
--   7/1/85  9:52 AM : ...and time out(#24)

WITH user_data ;
USE  user_data ;
WITH DEBUG_IO ;
WITH TEXT_IO ;
WITH SYSTEM ;
USE SYSTEM ;
PACKAGE BODY dec_tn_tasks IS

  SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ;

  TASK BODY tn IS --*********************** TN ********************************
    count : bit_count_8_type RANGE 0..255 := 0 ;
  BEGIN
    LOOP
      SELECT
        ACCEPT go DO
          count := count + 1 ;
        END go ;
      OR
        WHEN count > 0 =>
          ACCEPT wait DO
            count := count - 1 ;
          END wait ;
      END SELECT ;
    END LOOP ;
    EXCEPTION
      WHEN OTHERS =>
        TEXT_IO.PUT_LINE("EXCEPTION IN TASK TN.") ;
        DEBUG_IO.PUT_LINE("EXCEPTION IN TASK TN.") ;
        RAISE ;
  END tn ;


  TASK BODY telnet_buffer IS --************ telnet_buffer *********************
    message_buf : with_ulp_communicate.user_message ;
    room_in_buffer : BOOLEAN := TRUE ;
  BEGIN
    LOOP
      SELECT
        WHEN room_in_buffer =>
          ACCEPT put_tcp_message
                  (tcp_message : IN with_ulp_communicate.user_message) DO
            message_buf := tcp_message ;
            room_in_buffer := FALSE ;
            tn.go ;
          END put_tcp_message ;
      OR
        WHEN NOT(room_in_buffer) =>
          ACCEPT get_tcp_message
                  (tcp_message : OUT with_ulp_communicate.user_message) DO
            tcp_message := message_buf ;
            room_in_buffer := TRUE ;
          END get_tcp_message ;
      OR
        ACCEPT tcp_message_ready(buf_not_empty : OUT BOOLEAN) DO
          buf_not_empty := NOT(room_in_buffer) ;
        END tcp_message_ready ;
      END SELECT ;
    END LOOP ;
    EXCEPTION
      WHEN OTHERS =>
        TEXT_IO.PUT_LINE("EXCEPTION IN TASK TELNET_BUFFER") ;
        DEBUG_IO.PUT_LINE("EXCEPTION IN TASK TELNET_BUFFER") ;
        RAISE ;
  END telnet_buffer ;


  TASK BODY tcp_reader IS --****************** tcp_reader *********************
    message_from_tcp  : with_ulp_communicate.user_message ;
    done              : BOOLEAN ;
    ok_on_abort       : CONSTANT bit_count_16_type :=  8 ; -- tcp abort message
    connection_reset  : CONSTANT bit_count_16_type := 16 ; -- tcp reset message
    connection_closed : CONSTANT bit_count_16_type := 18 ; -- tcp closed message
    time_out          : CONSTANT bit_count_16_type := 24 ; -- tcp time_out messa
  BEGIN
    loop
      accept start ;
      done := false ;
      while not done LOOP
        message_from_tcp.local_connection_name :=
         user_data.user_control_block.lcn ;
        -- this will hang until a message is available...
        with_ulp_communicate.wait_for_tcp_message(message_from_tcp) ;
        telnet_buffer.put_tcp_message(message_from_tcp) ;
        IF (message_from_tcp.message_number = connection_closed) OR
           (message_from_tcp.message_number = time_out) OR
           (message_from_tcp.message_number = connection_reset) OR
           (message_from_tcp.message_number = ok_on_abort) THEN
          done := true ; -- don't read from non-existant mailbox
        END IF ;
      END LOOP ;
    end loop ;
    EXCEPTION
      WHEN OTHERS =>
        TEXT_IO.PUT_LINE("EXCEPTION IN TASK TCP_READER.") ;
        DEBUG_IO.PUT_LINE("EXCEPTION IN TASK TCP_READER.") ;
        RAISE ;
  END tcp_reader ;

BEGIN
  NULL ;
  EXCEPTION
    WHEN OTHERS =>
      TEXT_IO.PUT_LINE("EXCEPTION IN PACKAGE INSTANTIATION DEC_TN_TASKS") ;
      DEBUG_IO.PUT_LINE("EXCEPTION IN PACKAGE INSTANTIATION DEC_TN_TASKS") ;
      RAISE ;
END dec_tn_tasks ;

--::::::::::::::
--pvirtlpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01061-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         PVIRTLPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File pvirtlpac

--   5/7/85  9:10 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT
--  5/28/85 11:18 AM : mods for new_ncommu interface : lcn : lcn_type/lcn_ptr_type
--           3:12 PM : mods for new tcp interface
--  5/29/85  2:06 PM : mod to use Tele-lie Ada

--&MT OMIT NEXT LINE FOR DEC
--&MT PRAGMA SOURCE_INFO (ON) ;
WITH SYSTEM ; -- to access byte TYPE (8 bits)
USE SYSTEM ;
WITH user_data ;
WITH with_ulp_communicate ;
USE  with_ulp_communicate ;
WITH buffer_data ;
USE  buffer_data ;

PACKAGE virtual_transport_level -- specification
        -----------------------
 IS

-- ************************  USER SPECIFICATION  ****************************
--
-- A procedure will convert the desired transport level service call to the
-- proper syntax for the actual transport level inplementation (TCP) and
-- have the transport level process that service call.  It will provide
-- functions to determine if there are messages and input available from the
-- transport level.   It will get messages and input from the actual transport
-- level.  Messages are considered to be information from the local
-- transport level as apposed to input from the transport level which is
-- simply relayed data from the remote connection.
--
-- *************************************************************************

-------------------------  data specifications  ----------------------------

  --&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 ;

  TYPE transport_level_service_call_type IS
   (TL_open, TL_send, TL_receive, TL_close, TL_status, TL_abort) ;

  max_msg_length : CONSTANT bit_count_16_type := 256 ; -- arbitrary
  TYPE message_type IS ARRAY (1..max_msg_length) OF bit_count_8_type ;
  TYPE info_output_type IS ARRAY (bit_count_16_type RANGE <>) OF bit_count_8_type ;
  SUBTYPE input_type IS bit_count_8_type ;

  TYPE service_call_parameters_type
   (service_call : transport_level_service_call_type) IS
    RECORD
      CASE service_call IS
        WHEN TL_send =>
          urgent_flag : BOOLEAN ;
          info_length : bit_count_16_type RANGE 1..max_msg_length ;
          info        : info_output_type(1..max_msg_length) ;
        WHEN TL_open =>
          network_number      : bit_count_16_type := 10 ;
          host_number         : bit_count_16_type := 0 ;
          logical_host_number : bit_count_16_type := 0 ;
          imp_number          : bit_count_16_type := 0 ;
          port_number         : bit_count_16_type := 23 ;
        WHEN OTHERS =>
          NULL ;
       END CASE ;
     END RECORD ;

  -------------------  subprogram specifications  ---------------------------

  FUNCTION there_is_a_message  -- specification
           ------------------
   RETURN BOOLEAN ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This function returns true if there is a message available from
  -- the transport level.  A message is considered to be information
  -- originating at the local transport level.
  -------------------------------------------------------------------------


  FUNCTION there_is_input  -- specification
           --------------
   RETURN BOOLEAN ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This function returns true if there is data available from the remote
  -- TELNET.
  -------------------------------------------------------------------------


  PROCEDURE get_message -- specification
            -----------
   (message : OUT message_type ;
    length  : OUT bit_count_16_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure returns the next message from the local transport level.
  -- A message is considered to be information originating at the local
  -- transport level.
  -----------------------------------------------------------------------------


  PROCEDURE get_input -- specification
            ---------
   (input           : OUT input_type ;
    tcp_urgent_flag : OUT BOOLEAN) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure returns the next data item relayed from the remote
  -- telnet and indicates if it is urgent.
  -----------------------------------------------------------------------------


  FUNCTION there_is_room_for_info_output -- specification
           -----------------------------
   RETURN BOOLEAN ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure returns TRUE if there is buffer room for information
  -- to be sent to the local transport level.
  -----------------------------------------------------------------------------


  PROCEDURE send_data -- specification
            ---------
   (data : IN info_output_type ;
    urgent_flag : IN BOOLEAN) ;
  -- ***********************  USER SPECIFICATION  ***************************
  --
  -- This procedure sends data to the remote TELNET by presenting it to the
  -- local transport level as data and indicating if it is urgent.
  ---------------------------------------------------------------------------


  PROCEDURE send_message -- specification
            ------------
   (message : IN info_output_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure sends a message to the local transport level.
  -----------------------------------------------------------------------------


  PROCEDURE convert_service_call_to_transport_level_syntax -- specification
            ----------------------------------------------
   (service_call : IN transport_level_service_call_type ;
    parameter   : IN service_call_parameters_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- The transport level service call is converted into the syntax
  -- for a call to the actual transport level and that service is
  -- requested.  The user's APL buffers and state information are used.
  -----------------------------------------------------------------------------

END virtual_transport_level ; -- package specification


--::::::::::::::
--pvirtlpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01062-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         PVIRTLPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File pvirtlpac

--   5/7/85  9:10 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT
--  5/28/85 11:18 AM : mods for new_ncommu interface : lcn : lcn_type/lcn_ptr_type
--           3:12 PM : mods for new tcp interface
--  5/29/85  2:06 PM : mod to use Tele-lie Ada
--  6/11/85  5:29 PM : mods for new TCP interface (lcn)
--  6/12/85  9:57 AM : ditto
--  6/14/85  3:40 PM : mods for tasking
--  6/17/85 11:30 AM : use imp_number for local port on passive open for test
--  6/19/85  1:54 PM : save lcn after active open
--  6/20/85  1:54 PM : tcp_reader kick off upon opens
--           3:56 PM : after opens, replace recieve with another (see 14)
--           6:20 PM : in 14, use lcn_ptr instead of record
--  6/21/85  3:21 PM : fixed bug in send data to tcp
--  6/23/85  4:08 PM : alter send and receive tcp pointers
--  6/24/85  2:07 PM : only do passive open for server_telnet (tl_port#=0)
--  6/25/85  3:14 PM : omit tcp_reader.stop
--           4:23 PM : put dummy params in passive open from -1 to 0
--  6/26/85 10:24 AM : put print stm in passive open, omit state set on close
--  6/27/85  1:43 PM : mods for reset
--   7/1/85  9:48 AM : treat time out as a close
--           3:56 PM : call buffree after processing tcp data (#10 | #19)

WITH debug_io ;
WITH dec_tn_tasks ;

PACKAGE BODY virtual_transport_level IS -- body
             -----------------------
-- ****************************************************************************
-- Note : Generics could be used to take advantage of the comonality of
-- processing when supported by the compiler.
-------------------------------------------------------------------------------

  message_from_tcp : user_message ;
  lcn : with_ulp_communicate.lcn_ptr_type RENAMES
   user_data.user_control_block.lcn ;
  tl_data_is_urgent : BOOLEAN RENAMES
   user_data.user_control_block.rcv_data_is_urgent ; -- transport level data is urgent flag
  -- could be converted to urgent data byte count if convenient later...
  last_char_was_not_cr : BOOLEAN RENAMES
  user_data.user_control_block.last_data_char_rcv_not_cr ; -- flag for data characters
  request_ok : BOOLEAN ;
  lcn_record : with_ulp_communicate.lcn_ptr_type ;

  FUNCTION there_is_information_from_the_transport_level
           ---------------------------------------------
   RETURN BOOLEAN IS
    message_ready : BOOLEAN ;
  BEGIN
    message_from_tcp.local_connection_name := lcn ;

--&MT    wait_for_tcp_message(message_from_tcp) ; -- FOR TELESOFT ADA ON WICAT
    dec_tn_tasks.telnet_buffer.tcp_message_ready(message_ready) ;--&MT FOR DEC ADA
    IF message_ready THEN                                             --&MT
      dec_tn_tasks.telnet_buffer.get_tcp_message(message_from_tcp) ;  --&MT
    ELSE                                                              --&MT
      RETURN FALSE ;                                                  --&MT
    END IF ;                                                          --&MT

    IF message_from_tcp.message_number = -1 THEN
      RETURN FALSE ;
    END IF ;
    RETURN TRUE ;
  END there_is_information_from_the_transport_level ;


  PROCEDURE store_message (message : IN STRING) IS -- (local procedure)
            -------------
    tl_msg : user_data.trans_to_telnet_messages_record RENAMES
     user_data.user_control_block.trans_buffers.trans_to_telnet_messages ;
    msg_buf_length : CONSTANT bit_count_16_type :=
     user_data.trans_to_telnet_msg_buffer_length ;
  BEGIN
    debug_io.put_line("  in pvirtlpac.store_message(s)") ;
    debug_io.put("message ==>") ;
    debug_io.put_line(message(1..message'LENGTH)) ;
    FOR index IN 1..message'LENGTH LOOP
      tl_msg.buffer(tl_msg.buf_tail) :=
       bit_count_8_type(CHARACTER'POS(message(index))) ;
      tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ;
    END LOOP ;
      tl_msg.buffer(tl_msg.buf_tail) := 13 ; -- ascii.cr
      tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ;
    debug_io.put_line("  end pvirtlpac.store_message(s)") ;
    EXCEPTION
      WHEN OTHERS =>
        DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.STORE_MESSAGE(s)") ;
        RAISE ;
  END store_message ;


  PROCEDURE get_and_process_information_from_the_transport_level IS
            ----------------------------------------------------

    PROCEDURE store_message (number : IN bit_count_32_type) IS
              -------------
      digit : bit_count_16_type RANGE 0..9 ;
      num   : bit_count_32_type := number ;
      number_string : STRING (1..20) ;
      num_digits : bit_count_32_type RANGE 0..19 := 0 ;
      --&MT num_digits : bit_count_16_type RANGE 0..19 := 0 ;
    BEGIN
      debug_io.put_line("  in pvirtlpac.store_message(i)") ;
      IF number > 0 THEN
        WHILE num > 0 LOOP
          debug_io.put("number=") ;
          debug_io.put_line(bit_count_16_type(number)) ;
          digit := bit_count_16_type(num - (num/bit_count_32_type(10)) * bit_count_32_type(10)) ; -- extract next digit
          debug_io.put("digit=") ;
          debug_io.put_line(digit) ;
          num := num / bit_count_32_type(10) ;
          number_string(20 - num_digits) := CHARACTER'VAL(digit+16#30#) ;
          debug_io.put("digit_char =") ;
          debug_io.put_line(number_string(20 - num_digits)) ;
          num_digits := num_digits + 1 ;
          debug_io.put("num_digits=") ;
          debug_io.put_line(bit_count_16_type(num_digits)) ;
        END LOOP ;
        number_string(1..num_digits) := number_string(21-num_digits..20) ;
      ELSE
        num_digits := 1 ;
        number_string(1) := '0' ;
      END IF ; -- number = 0 ?
      debug_io.put("number_string(1..num_digits)=") ;
      debug_io.put_line(number_string(1..num_digits)) ;
      store_message(number_string(1..num_digits)) ;
      debug_io.put_line("  end pvirtlpac.store_message(i)") ;
    EXCEPTION
      WHEN OTHERS =>
        DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.STORE_MESSAGE(i)") ;
        RAISE ;
    END store_message ;

    PROCEDURE do_passive_open  IS
              ---------------
      tcp_options         : tcp_option_type ;
      open_parameters     : open_params ;
      the_message_for_tcp : message ;
    BEGIN
      debug_io.put_line("in passive open routine") ;
      IF user_data.user_control_block.tl_port_number = 0 THEN -- server_telnet
        debug_io.put_line("will attempt passive open") ;
        FOR index IN 1..50 LOOP
          tcp_options(index) := 0 ;
        END LOOP ;
        open_parameters := (2, --TBD hard wire for test
         0,0,with_ulp_communicate.passive,0,255,lcn_record,0,0,tcp_options) ;
        the_message_for_tcp := (with_ulp_communicate.open, open_parameters) ;
        message_for_tcp(the_message_for_tcp, request_ok) ;
        lcn := the_message_for_tcp.open_parameters.local_connection_name ;
        dec_tn_tasks.tcp_reader.start ;
      END IF ;
      debug_io.put_line("end passive open") ;
    END do_passive_open ;


  BEGIN
    debug_io.put_line("in vir_tl get_and_process_information...") ;
    debug_io.put("msg #=") ;
    debug_io.put_line(message_from_tcp.message_number) ;
    CASE message_from_tcp.message_number IS
      WHEN 2 => store_message("connection illegal") ;
      WHEN 3 => store_message("connection does not exist") ;
      WHEN 4 => store_message("foreign socket unpsecified") ;
      WHEN 5 => store_message("insufficient resources") ;
      WHEN 6 => store_message("connection closing") ; -- close sent from remote
        user_data.user_control_block.communication_state :=
         user_data.no_connection_established ;
        DECLARE
          parameter : service_call_parameters_type(tl_close) ;
        BEGIN
          convert_service_call_to_transport_level_syntax(tl_close, parameter) ;
        END ;
      WHEN 7 => store_message("performing urgent data processing") ;
        tl_data_is_urgent := TRUE ;
      WHEN 8 => store_message("connection aborted") ;
        user_data.reset_user_control_block ; -- reset to initial values
        do_passive_open ;
      WHEN 9 => store_message("precedence not allowed") ;
      WHEN 10 | 19 => -- data from remote
        DECLARE -- data
          tl_data : user_data.trans_to_telnet_data_record RENAMES
           user_data.user_control_block.trans_buffers.trans_to_telnet_data ;
          data_buf_length : CONSTANT bit_count_16_type :=
           user_data.trans_to_telnet_data_buffer_length ;
          char_count : bit_count_16_type :=
           message_from_tcp.data_buffer.telnet_ptr -
           message_from_tcp.data_buffer.tcp_ptr ;
          cr : CONSTANT bit_count_8_type := 13 ; -- ascii carraige return
        BEGIN

          debug_io.put_line("data msg detected") ;
          debug_io.put("  telnet_ptr=") ;
          debug_io.put(message_from_tcp.data_buffer.telnet_ptr) ;
          debug_io.put("  tcp_ptr :=") ;
          debug_io.put_line(message_from_tcp.data_buffer.tcp_ptr) ;

          FOR index IN 0..char_count LOOP

            debug_io.put("  position =") ;
            debug_io.put(message_from_tcp.data_buffer.telnet_ptr - index) ;
            debug_io.put("  char_code =") ;
            debug_io.put_line_byte(message_from_tcp.data_buffer.byte
             (message_from_tcp.data_buffer.telnet_ptr - index)) ;

            IF last_char_was_not_cr THEN
              tl_data.buffer(tl_data.buf_tail) :=
               message_from_tcp.data_buffer.byte
               (message_from_tcp.data_buffer.telnet_ptr - index) ;
              tl_data.buf_tail := (tl_data.buf_tail + 1) MOD data_buf_length ;
              debug_io.put_line("stored") ;
            END IF ; -- not cr?
            IF message_from_tcp.data_buffer.byte
             (message_from_tcp.data_buffer.telnet_ptr - index) = cr THEN
              last_char_was_not_cr := FALSE ;
            ELSE
              last_char_was_not_cr := TRUE ;
            END IF ;
          END LOOP ;
          buffree(message_from_tcp.data_buffer, 0) ;
          -- replace the satisfied receive with another receive
          DECLARE -- receive
            packed_buffer : packed_buffer_ptr ;
            receive_data  : receive_params ;
            task_message  : message ;
          BEGIN
            buffget(packed_buffer,1) ;
            IF packed_buffer = NULL THEN
              debug_io.put_line("Unable to get buffer for a receive.") ;
              store_message("Unable to get buffer for a receive.") ;
            ELSE
             lcn_record := message_from_tcp.local_connection_name ;
             receive_data := (lcn_record, packed_buffer, 190) ;
             task_message := (receive, receive_data) ;
             message_for_tcp(task_message, request_ok) ;
            END IF ; -- null?
          END ; -- receive declare
        END ; -- data declare
      WHEN 11 => store_message("security/compartment illegal") ;
      WHEN 12 => store_message("connection exists") ;
      WHEN 14 => -- return lcn from open request
        debug_io.put_line("return lcn msg detected") ;
        lcn.lcn_ptr := message_from_tcp.local_connection_name.lcn_ptr ;
        --&MT replace the satisfied receive with another receive
        DECLARE -- receive
          packed_buffer : packed_buffer_ptr ;
          receive_data  : receive_params ;
          task_message  : message ;
        BEGIN
          buffget(packed_buffer,1) ;
          IF packed_buffer = NULL THEN
            debug_io.put_line("Unable to get buffer for a receive.") ;
            store_message("Unable to get buffer for a receive.") ;
          ELSE
            lcn_record.lcn_ptr :=
             message_from_tcp.local_connection_name.lcn_ptr ;
            receive_data := (lcn_record, packed_buffer, 190) ;
            task_message := (receive, receive_data) ;
            message_for_tcp(task_message, request_ok) ;
          END IF ; -- null?
        END ; -- receive declare
      WHEN 15 => -- status
        debug_io.put_line("status msg detected") ;
       DECLARE
       -- &MT  the : status_record RENAMES message_from_tcp.status_params ;
       -- &MT  variant record component status_params is not renamable in dec ada
       BEGIN
        store_message(" ") ;
        store_message("status information :") ;
        store_message(" ") ;
        store_message("source port=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.source_port)) ;
        store_message("source address=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.source_address)) ;
        store_message("destination address=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.destination_address)) ;
        store_message("destination port=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.destination_port)) ;
        store_message("# of octets we can accept=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.local_rcv_window)) ;
        store_message("# of octets that can be sent=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.remote_rcv_window)) ;
        store_message("amount of data on retran q =") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.octets_on_retransmit_queue)) ;
        store_message("amount of data waiting for us =") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.data_waiting_for_ulp)) ;
        IF message_from_tcp.status_params.urgent_state THEN
          store_message("urgent state=true") ;
        ELSE
          store_message("urgent state=false") ;
        END IF ;
        store_message("precedence value=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.precedence)) ;
        store_message("user layer timeout=") ;
        store_message(bit_count_32_type(message_from_tcp.status_params.ulp_timeout)) ;
        store_message("security values=") ;
        FOR index IN 1..9 LOOP
          store_message(bit_count_32_type(message_from_tcp.status_params.security(index))) ;
        END LOOP ;
        IF message_from_tcp.status_params.status = with_ulp_communicate.connection_open THEN
          store_message("connection open") ;
        ELSE
          store_message("connection closed") ;
        END IF ;
        store_message("message_from_tcp.status_params TCB state is") ;
        CASE message_from_tcp.status_params.connection_state IS
          WHEN closed                         => store_message("closed") ;
          WHEN with_ulp_communicate.listen    => store_message("listen") ;
          WHEN syn_sent                       => store_message("syn_sent") ;
          WHEN syn_received                   => store_message("syn received") ;
          WHEN established                    => store_message("established") ;
          WHEN fin_wait_1                     => store_message("fin_wait_1") ;
          WHEN fin_wait_2                     => store_message("fin_wait_2") ;
          WHEN close_wait                     => store_message("close_wait") ;
          WHEN last_ack                       => store_message("last_ack") ;
          WHEN time_wait                      => store_message("time_wait") ;
          WHEN OTHERS                         => store_message("closing") ;
        END CASE ;
       END ; -- status declare
      WHEN 16 => store_message("connection reset by other host") ;
        user_data.reset_user_control_block ; -- reset to initial values
        do_passive_open ;
      WHEN 17 => store_message("connection refused") ;
      WHEN 18 => store_message("connection closed") ;
        user_data.reset_user_control_block ; -- reset to initial values
        do_passive_open ;
      WHEN 20 => store_message("out of buffers in a lower layer") ;
      WHEN 21 => store_message("unable to reset") ;
      WHEN 22 => store_message("the ip is currently overloaded") ;
      WHEN 23 => -- connection open
        debug_io.put_line("connection open msg detected") ;
        user_data.user_control_block.communication_state :=
         user_data.connection_established ;
        debug_io.put_line
         ("communication_state set to connection_established") ;
        store_message("connection open") ;
      WHEN 24 => store_message("error: connection aborted due to user time out") ;
        user_data.reset_user_control_block ; -- reset to initial values
        do_passive_open ;
      WHEN OTHERS =>
        debug_io.put("unknown msg # detected ==>") ;
        debug_io.put_line(message_from_tcp.message_number) ;
    END CASE ;
    debug_io.put_line("end vir_tl get_and_process_information...") ;
  EXCEPTION
    WHEN OTHERS =>
      DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.GET_AND_PROC_INFO") ;
      RAISE ;
  END get_and_process_information_from_the_transport_level ;

----------------------------- END LOCAL SUBPROGRAMS ---------------------------

  FUNCTION there_is_a_message  -- body
           ------------------
  RETURN BOOLEAN IS
  -- (for test/debug use user_data.trans_input_buffer for the mock
  -- TCP interface buffer)

    message : user_data.trans_to_telnet_messages_record RENAMES
     user_data.user_control_block.trans_buffers.trans_to_telnet_messages ;
    buf_length : CONSTANT bit_count_16_type :=
     user_data.trans_to_telnet_msg_buffer_length ;

  BEGIN
    debug_io.put_line("in vir_tl there is a message") ;
    IF there_is_information_from_the_transport_level THEN
      debug_io.put_line("calling get&process because there is information") ;
      get_and_process_information_from_the_transport_level ;
    END IF ;
    debug_io.put_line("end vir_tl there is a message") ;
    RETURN (message.buf_head + 1) MOD buf_length /= message.buf_tail ;
  END there_is_a_message ; -- body


  FUNCTION there_is_input  -- body
           --------------
   RETURN BOOLEAN IS
  -- (for test/debug use user_data.trans_input_buffer for the mock
  -- TCP interface buffer)

    data : user_data.trans_to_telnet_data_record RENAMES
     user_data.user_control_block.trans_buffers.trans_to_telnet_data ;
    buf_length : CONSTANT bit_count_16_type :=
     user_data.trans_to_telnet_msg_buffer_length ;

  BEGIN
    debug_io.put_line("in vir_tl there is input") ;
    IF there_is_information_from_the_transport_level THEN
      debug_io.put_line("call get and process") ;
      get_and_process_information_from_the_transport_level ;
    END IF ;
    debug_io.put_line("end vir_tl there is input") ;
    RETURN (data.buf_head + 1) MOD buf_length /= data.buf_tail ;
  END there_is_input ; -- body


  PROCEDURE get_message -- body
            -----------
   (message : OUT message_type ;
    length  : OUT bit_count_16_type) IS

    mess : user_data.trans_to_telnet_messages_record RENAMES
     user_data.user_control_block.trans_buffers.trans_to_telnet_messages ;
    buf_length : CONSTANT bit_count_16_type :=
     user_data.trans_to_telnet_msg_buffer_length ;
    there_is_more : BOOLEAN := TRUE ;
    message_length : bit_count_16_type ;
      -- $MT  new local variable declared to resolve error of reading from
      -- subprogram 'out'.'
  BEGIN
    debug_io.put_line("in get message") ;
    message_length := 0 ;
      -- &MT message_length replaced length
    IF there_is_a_message THEN
      WHILE there_is_more LOOP
        mess.buf_head := (mess.buf_head + 1) MOD buf_length ;
        IF mess.buffer(mess.buf_head) = 16#0D# THEN -- ascii.cr, end of message
          there_is_more := FALSE ;
        END IF ; -- eom?
        message_length := message_length + 1 ;
        message(message_length) := mess.buffer(mess.buf_head) ;
          -- &MT message_length replaced length
      END LOOP ; -- do all
    END IF ; -- message present?
    length := message_length ;
    debug_io.put(" at end of get message... ") ;
  EXCEPTION
    WHEN OTHERS =>
      DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.GET_MESSAGE") ;
      RAISE ;
  END get_message ; -- body


  PROCEDURE get_input -- body
            ---------
   (input : OUT input_type ;
    tcp_urgent_flag : OUT BOOLEAN) IS
-- this urgent handling will change when tcp passes back the flag with a get

    data : user_data.trans_to_telnet_data_record RENAMES
     user_data.user_control_block.trans_buffers.trans_to_telnet_data ;
    buf_length : CONSTANT bit_count_16_type :=
     user_data.trans_to_telnet_data_buffer_length ;
    there_is_more : BOOLEAN := TRUE ;
    temp_input : input_type ;
      -- $MT  new local variable declared to resolve error of reading from
      -- subprogram 'out'.'

  BEGIN
    debug_io.put_line("pvirtlpac.get_input begin") ;
    tcp_urgent_flag := tl_data_is_urgent ;
    IF there_is_input THEN
      data.buf_head := (data.buf_head + 1) MOD buf_length ;
      temp_input := data.buffer(data.buf_head);
        -- &MT  temp_input replaced input
      debug_io.put("input code =") ;
      debug_io.put_line_byte(temp_input) ;
        -- &MT  temp_input replaced input
    END IF ; -- data present?
    input := temp_input ;
    debug_io.put_line("pvirtlpac.get_input end") ;
    EXCEPTION
      WHEN OTHERS =>
        DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.GET_INPUT") ;
        RAISE ;
  END get_input ; -- body


  FUNCTION there_is_room_for_info_output -- body
           -----------------------------
   RETURN BOOLEAN IS
--MT    output : user_data.trans_output_buffer_record RENAMES
--MT     user_data.user_control_block.trans_buffers.trans_output_buffer ;
--MT    max_buf_length : CONSTANT bit_count_16_type := user_data.trans_out_buffer_length ;
  BEGIN
--MT    RETURN output.length < max_buf_length ;
    RETURN TRUE ;
  END there_is_room_for_info_output ;


  PROCEDURE send_data -- body
            ---------
   (data : IN info_output_type ;
    urgent_flag : IN BOOLEAN) IS

    parameter : service_call_parameters_type(TL_send) ; -- can't do TeleSoft
                                                       -- aggregate assign here
  BEGIN -- send_data
    debug_io.put_line("begin vir_tl.send_data") ;
    parameter.urgent_flag := urgent_flag ;
    parameter.info_length := data'LENGTH ;
    FOR index IN data'RANGE LOOP -- copy rest of string
      parameter.info(index) := data(index) ;
    END LOOP ;
    convert_service_call_to_transport_level_syntax(TL_send, parameter) ;
    debug_io.put_line("end vir_tl.send_data") ;
  EXCEPTION
    WHEN OTHERS =>
      DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.SEND_DATA") ;
      RAISE ;
  END send_data ;


  PROCEDURE send_message -- body
            ------------
   (message : IN info_output_type) IS
    parameter : service_call_parameters_type(TL_send) ;-- can't do (TeleSoft)
                                                       -- aggregate assign here
  BEGIN
    debug_io.put_line("begin vir_tl.send_message") ;
    parameter.urgent_flag := false ;
    parameter.info_length := message'LENGTH ;
    parameter.info(1..message'LENGTH) := message(1..message'LENGTH) ;
    convert_service_call_to_transport_level_syntax(TL_send, parameter) ;
    debug_io.put_line("end vir_tl.send_message") ;
  EXCEPTION
    WHEN OTHERS =>
      DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.SEND_MESSAGE") ;
      RAISE ;
  END send_message ;


  PROCEDURE convert_service_call_to_transport_level_syntax -- body
            ----------------------------------------------
   (service_call : IN transport_level_service_call_type ;
    parameter   : IN service_call_parameters_type) IS

    the_message_for_tcp : message ;

  BEGIN -- convert_service_call_to_transport_level_syntax
    debug_io.put_line("begin vir_tl.convert_service call...") ;
    IF (service_call = tl_open) THEN                       -- ****** OPEN ******
      debug_io.put_line("virt_tl processed open call to TCP") ;
      debug_io.put("network_number=") ;
      debug_io.put_line(parameter.network_number) ;
      debug_io.put("host_number=") ;
      debug_io.put_line(parameter.host_number) ;
      debug_io.put("logical_host_number=") ;
      debug_io.put_line(parameter.logical_host_number) ;
      debug_io.put("imp_number=") ;
      debug_io.put_line(parameter.imp_number) ;
      debug_io.put("port_number=") ;
      debug_io.put_line(parameter.port_number) ;
      DECLARE
        foreign_net_host : bit_count_32_type ;
        options : tcp_option_type ;
        open_parameters : open_params ;

        FUNCTION calculate_class_a_address (net, imp, host : IN bit_count_16_type)
         RETURN bit_count_32_type IS
        BEGIN
          RETURN bit_count_32_type(16#1000000#) * bit_count_32_type(net) -- high byte
               + bit_count_32_type(256) * bit_count_32_type(imp) -- middle 2 bytes
               + bit_count_32_type(host) ; -- low byte
        END calculate_class_a_address ;

      BEGIN -- (only class A networks currently supported)
        user_data.user_control_block.tl_port_number := parameter.port_number ;
--        foreign_net_host := calculate_class_a_address(parameter.network_number,
--         parameter.imp_number, parameter.host_number) ;
        FOR index IN 1..50 LOOP
          options(index) := 0 ;
        END LOOP ;
        foreign_net_host := bit_count_32_type(parameter.logical_host_number) ; -- for testing
        lcn_record := lcn ;
        --use imp as local port number for testing (really 23)
        open_parameters := (parameter.imp_number, parameter.port_number,
         foreign_net_host, active, 0, 15, lcn_record, 0, 0, options) ;
        the_message_for_tcp := (with_ulp_communicate.open, open_parameters) ;
        message_for_tcp(the_message_for_tcp, request_ok) ;
        lcn := the_message_for_tcp.open_parameters.local_connection_name ;
        dec_tn_tasks.tcp_reader.start ;
      END ; -- open declare
    ELSIF service_call = tl_send THEN                     -- ****** SEND ******
      debug_io.put_line("virt_tl processing send call to TCP") ;
      DECLARE
        packed_buffer  : packed_buffer_ptr ;
        send_data      : send_params ;
        tl_byte_count  : bit_count_16_type := parameter.info_length - 1 ;
        tl_push_flag   : CONSTANT bit_count_16_type := 1 ; -- do push
        tl_urgent_flag : bit_count_16_type := 0 ; -- not urgent
        tl_time_out    : CONSTANT bit_count_16_type := 15 ; -- arbitrary
        buffer_index   : bit_count_16_type := 0 ;
        cr             : CONSTANT bit_count_8_type := 13 ;-- ascii carraige return
        lf             : CONSTANT bit_count_8_type := 10 ;-- ascii line feed

      BEGIN -- tl_send declare
        debug_io.put_line("in pvirtlpac.send_data to tcp (actual tcp call)") ;
        IF parameter.info_length > 0 THEN
          buffget(packed_buffer,1) ;
          IF packed_buffer = NULL THEN
            store_message("out of buffers") ;
          ELSE
            IF parameter.urgent_flag THEN tl_urgent_flag := 1 ; END IF ;
            FOR index IN 1..parameter.info_length LOOP
              packed_buffer.byte(packed_buffer.telnet_ptr - buffer_index) :=
               parameter.info(index) ;
              buffer_index := buffer_index + 1 ;
              debug_io.put("data code=") ;
              debug_io.put_line_byte(parameter.info(index)) ;
              IF parameter.info(index) = cr THEN -- see RFC 854 page 11,12
                packed_buffer.byte(packed_buffer.telnet_ptr - buffer_index) := lf ;
                buffer_index := buffer_index + 1 ;
                debug_io.put("data code=") ;
                debug_io.put_byte(lf) ;
                debug_io.put_line("  lf inserted") ;
              END IF ; -- cr?
            END LOOP ;
            lcn_record := lcn ;
            tl_byte_count := buffer_index - 1 ;
            packed_buffer.telnet_ptr := packed_buffer.telnet_ptr - tl_byte_count;
            packed_buffer.tcp_ptr := packed_buffer.telnet_ptr - 1 ;

            debug_io.put("tl_byte_count=") ;
            debug_io.put_line(tl_byte_count) ;
            debug_io.put("telnet_ptr=") ;
            debug_io.put_line(packed_buffer.telnet_ptr) ;
            debug_io.put("tcp_ptr=") ;
            debug_io.put_line(packed_buffer.tcp_ptr) ;

            send_data := (lcn_record, packed_buffer, tl_byte_count,
             tl_push_flag, tl_urgent_flag, tl_time_out) ;
            the_message_for_tcp := (send, send_data) ;
            message_for_tcp(the_message_for_tcp, request_ok) ;
          END IF ; -- packed buffer = NULL ?
        END IF ; -- length > 0 ?
      END ; -- tl_send declare
      debug_io.put_line("end virt_tl processing send call to TCP") ;
    ELSIF service_call = tl_receive THEN               -- ****** RECEIVE ******
      debug_io.put_line("virt_tl processed receive call to TCP") ;
    ELSIF service_call = tl_close THEN                -- ******* CLOSE *******
      debug_io.put_line("virt_tl processing close call to TCP") ;
      DECLARE
        close_params : abort_close_params ;
      BEGIN
        lcn_record := lcn ;
        close_params := (local_connection_name => lcn_record) ;
        the_message_for_tcp := (with_ulp_communicate.close, close_params) ;
        message_for_tcp(the_message_for_tcp, request_ok) ;
      END ;
      debug_io.put_line("communication_state is no_connection_established") ;
    ELSIF service_call = tl_status THEN                -- ****** STATUS ******
      debug_io.put_line("virt_tl processing status call to TCP") ;
      DECLARE
        status_data : status_params ;
      BEGIN
        lcn_record := lcn ;
        status_data := (local_connection_name => lcn_record) ;
        the_message_for_tcp := (with_ulp_communicate.status, status_data) ;
        message_for_tcp(the_message_for_tcp, request_ok) ;
      END ;
    ELSIF service_call = tl_abort THEN                  -- ****** ABORT ******
      debug_io.put_line("virt_tl processing abort call to TCP") ;
      DECLARE
        abort_params : abort_close_params ;
      BEGIN
        lcn_record := lcn ;
        abort_params := (local_connection_name => lcn_record) ;
        the_message_for_tcp := (with_ulp_communicate.abor_t, abort_params) ;
        message_for_tcp(the_message_for_tcp, request_ok) ;
      END ;
    ELSE
      debug_io.put_line("unrecognized service call") ;
    END IF ; -- service type?
    debug_io.put_line("end of convt serv call to tl syntax") ;
  EXCEPTION
    WHEN OTHERS =>
      DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.CONVERT...") ;
      RAISE ;
  END convert_service_call_to_transport_level_syntax ; -- body


BEGIN
  NULL ;
  EXCEPTION
    WHEN OTHERS =>
      DEBUG_IO.PUT_LINE("@@@EXCEPTION IN PVIRTLPAC.INSTAINTIATION") ;
      RAISE ;
END virtual_transport_level ; -- package body
--::::::::::::::
--poptngpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01059-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         POPTNGPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File poptngpac

--   5/7/85  1:50 PM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT
--   7/1/85  1:28 PM : remove status variable from request calls

WITH user_data ;
USE  user_data ; --&MT added this to help with handling of enumerated types
WITH SYSTEM ; -- access system.byte

PACKAGE option_negotiation -- specification
        ------------------
 IS
  --*********************  USER SPECIFICATION  ********************************
  --
  -- This package will have routines to negotiate the transfer syntax and
  -- virtual resource characteristics.  A procedure will negotiate initial
  -- options.  Additionally, procedures can be called to explicitly request
  -- option enable or demand option disable of a particular option at any time.
  -- **************************************************************************

-- NOTE : This compiles OK but does not work properly during runtime.
-- so get directly from user_data until on a real ADA compiler
--  SUBTYPE ppl_option_type IS user_data.option_type ;

--&MT SUBTYPE bit_count_8_type IS SYSTEM.BYTE ;
  SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ;


  PROCEDURE request_local_option_enable -- specification
            ---------------------------
   (option : IN user_data.option_type) ;

  -- ************************  USER SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is not already in effect,
  -- this procedure will negotiate for that option.  If there is no connection
  -- established, the desirable option tables will be updated and TELNET
  -- PPL will try to negotiate these options at the establishment of a new
  -- connection.
  -----------------------------------------------------------------------------


  PROCEDURE demand_local_option_disable -- specification
            ---------------------------
   (option : IN user_data.option_type) ;

  -- ************************  USER SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is already in effect,
  -- this procedure will negotiate the cessation of that option.  If there is
  -- no connection established, the desirable option tables will be updated
  -- and TELNET PPL will not try to negotiate this option at the establishment
  -- of a new connection.
  -----------------------------------------------------------------------------


  PROCEDURE request_remote_option_enable -- specification
            ----------------------------
   (option : IN user_data.option_type) ;

  -- ************************  USER SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is not already in effect,
  -- this procedure will negotiate for that option.  If there is no connection
  -- established, the desirable option tables will be updated and TELNET PPL
  -- will try to negotiate these options at the establishment of a new
  -- connection.
  -----------------------------------------------------------------------------


  PROCEDURE demand_remote_option_disable -- specification
            ----------------------------
   (option : IN user_data.option_type) ;

  -- ************************  USER SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is already in effect,
  -- this procedure will negotiate the cessation of that option.  If there is
  -- no connection established, the desirable option tables will be updated
  -- and TELNET PPL will not try to negotiate this option at the establishment
  -- of a new connection.
  -----------------------------------------------------------------------------


  PROCEDURE negotiate_initial_desired_options ; -- specification
            ---------------------------------

  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will use the information contained in the desirable
  -- options tables to negotiate options with the remote TELNET.
  -----------------------------------------------------------------------------


  PROCEDURE remote_will_received  -- specification
            --------------------
   (option_code : IN bit_count_8_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure will inform the option negotiation subprograms that a
  -- WILL (option) was received from the remote TELNET.
  -------------------------------------------------------------------------


  PROCEDURE remote_wont_received  -- specification
            --------------------
   (option_code : IN bit_count_8_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure will inform the option negotiation subprograms that a
  -- WONT (option) was received from the remote TELNET.
  -------------------------------------------------------------------------


  PROCEDURE remote_do_received  -- specification
            ------------------
   (option_code : IN bit_count_8_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure will inform the option negotiation subprograms that a
  -- DO (option) was received from the remote TELNET.
  -------------------------------------------------------------------------


  PROCEDURE remote_dont_received  -- specification
            --------------------
   (option_code : IN bit_count_8_type) ;
  -- *************************  USER SPECIFICATION  ***************************
  --
  -- This procedure will inform the option negotiation subprograms that a
  -- DONT (option) was received from the remote TELNET.
  -------------------------------------------------------------------------

END option_negotiation ; -- package specification

--::::::::::::::
--poptngpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01060-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         POPTNGPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File poptngpac
--   7-1-85  1:32 PM : remove status var from requests
--           5:46 PM : fix bug in option negotiation disable,dont,wont

WITH debug_io ;
WITH virtual_transport_level ;
WITH dec_tn_tasks ;

PACKAGE BODY option_negotiation IS
             ------------------

--&MT SUBTYPE bit_count_16_type IS INTEGER ;
  SUBTYPE bit_count_16_type IS SHORT_INTEGER ;

  TYPE action_type IS (tn_will, tn_wont, tn_do, tn_dont) ;
  TYPE action_code_array_type IS ARRAY(action_type) OF bit_count_8_type ;
  TYPE option_code_array_type IS ARRAY(user_data.option_type) OF bit_count_8_type ;
  action_kind : action_type ;
  action_code : action_code_array_type ;-- aggregate asignment not implimented
  option_code : option_code_array_type ;-- during decl.(do assign in body part)
  echo : user_data.option_type ; -- TeleSoft-Ada can't do assign here
  suppress_ga : user_data.option_type ; -- ditto
  IAC : CONSTANT bit_count_8_type := 255 ; -- interprate as command code

  option_tables            : user_data.option_tables_type RENAMES
   user_data.user_control_block.option_tables ;
  local_options_desired    : user_data.option_table_type RENAMES
   option_tables.local_options_desired ;
  local_options_in_effect  : user_data.option_table_type RENAMES
   option_tables.local_options_in_effect ;
  local_options_pending    : user_data.option_table_type RENAMES
   option_tables.local_options_pending ;
  remote_options_desired   : user_data.option_table_type RENAMES
   option_tables.remote_options_desired ;
  remote_options_in_effect : user_data.option_table_type RENAMES
   option_tables.remote_options_in_effect ;
  remote_options_pending   : user_data.option_table_type RENAMES
   option_tables.remote_options_pending ;


  PROCEDURE store_message (message : IN STRING) IS -- (local procedure)
            -------------
    tl_msg : user_data.trans_to_telnet_messages_record RENAMES
     user_data.user_control_block.trans_buffers.trans_to_telnet_messages ;
    msg_buf_length : CONSTANT bit_count_16_type :=
     user_data.trans_to_telnet_msg_buffer_length ;
  BEGIN
    FOR index IN 1..message'LENGTH LOOP
      tl_msg.buffer(tl_msg.buf_tail) :=
       bit_count_8_type(CHARACTER'POS(message(index))) ;
      tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ;
    END LOOP ;
    tl_msg.buffer(tl_msg.buf_tail) := 10 ; -- ascii.lf
    tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ;
    tl_msg.buffer(tl_msg.buf_tail) := 13 ; -- ascii.cr
    tl_msg.buf_tail := (tl_msg.buf_tail + 1) MOD msg_buf_length ;
    dec_tn_tasks.tn.go ; -- make sure message gets out --&MT (dec only)
    EXCEPTION
      WHEN OTHERS =>
        DEBUG_IO.PUT_LINE("@@@ EXCEPTION IN POPTNGPAC.STORE_MESSAGE") ;
        RAISE ;
  END store_message ;


  PROCEDURE send_option
            -----------
   (action : IN action_type ;
    option : IN user_data.option_type) IS
    data : virtual_transport_level.info_output_type(1..3) ;
  BEGIN
    data(1) := IAC ;
    data(2) := action_code(action) ;
    data(3) := option_code(option) ;
    virtual_transport_level.send_data(data, FALSE) ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.send_option(o)") ;
      RAISE ;
  END send_option ;


  PROCEDURE send_option
            -----------
   (action      : IN action_type ;
    option_code : IN bit_count_8_type) IS
    data : virtual_transport_level.info_output_type(1..3) ;
  BEGIN
    data(1) := IAC ;
    data(2) := action_code(action) ;
    data(3) := option_code ;
    virtual_transport_level.send_data(data, FALSE) ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.send_option(c)") ;
      RAISE ;
  END send_option ;


  PROCEDURE send_message
            ------------
   (message : IN STRING) IS
    tl_message : virtual_transport_level.info_output_type(1..message'LENGTH) ;
  BEGIN
    FOR index IN message'RANGE LOOP -- convert to system.byte
      tl_message(bit_count_16_type(index)) :=
       bit_count_8_type(CHARACTER'POS(message(index))) ;
    END LOOP ;
    virtual_transport_level.send_message(tl_message) ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.send_message") ;
      RAISE ;
  END send_message ;


  FUNCTION option_in_table
           ---------------
   (table  : IN user_data.option_table_type ;
    option : IN user_data.option_type) RETURN BOOLEAN IS
  BEGIN
    FOR index IN 1..table.number_of_items LOOP
      IF table.option(bit_count_16_type(index)) = option THEN
        RETURN TRUE ;
      END IF ;
    END LOOP ;
    RETURN FALSE ;
  END option_in_table ;


  FUNCTION local_option_already_in_effect_or_being_negotiated
           --------------------------------------------------
   (option : IN user_data.option_type) RETURN BOOLEAN IS
  BEGIN
    IF option_in_table(local_options_in_effect, option)THEN RETURN TRUE ;END IF ;
    IF option_in_table(local_options_pending, option) THEN RETURN TRUE ; END IF ;
    RETURN FALSE ;
  END local_option_already_in_effect_or_being_negotiated ;


  FUNCTION remote_option_already_in_effect_or_being_negotiated
           ---------------------------------------------------
   (option : IN user_data.option_type) RETURN BOOLEAN IS
  BEGIN
    IF option_in_table(remote_options_in_effect,option) THEN RETURN TRUE ;END IF;
    IF option_in_table(remote_options_pending, option) THEN RETURN TRUE ;END IF ;
    RETURN FALSE ;
  END remote_option_already_in_effect_or_being_negotiated ;


  PROCEDURE add_option_to_table -- no check for overflow or duplication
            -------------------
   (table  : IN OUT user_data.option_table_type ;
    option : IN     user_data.option_type) IS
  BEGIN
    table.number_of_items := table.number_of_items + 1 ;
    table.option(table.number_of_items) := option ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.add_option_") ;
      RAISE ;
  END add_option_to_table ;


  PROCEDURE delete_option_from_table
            ------------------------
   (table  : IN OUT user_data.option_table_type ;
    option : IN     user_data.option_type) IS -- dedicated to Evanne
    save_index : bit_count_16_type RANGE 0..user_data.number_of_options_supported := 0 ;
  BEGIN
    FOR index IN 1..table.number_of_items LOOP
      IF table.option(bit_count_16_type(index)) /= option THEN
        save_index := save_index + 1 ;
        table.option(save_index) := table.option(index) ;
      END IF ;
    END LOOP ;
    table.number_of_items := save_index ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.delete_option_") ;
      RAISE ;
  END delete_option_from_table ;


  PROCEDURE request_local_option_enable -- body
            ---------------------------
   (option : IN  user_data.option_type) IS

  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is not already in effect,
  -- this procedure will negotiate for that option.  Otherwise, the desirable
  -- option tables will be updated and TELNET PPL will try to negotiate these
  -- options at the establishment of a new connection.
  -----------------------------------------------------------------------------
  BEGIN
    IF (user_data.user_control_block.communication_state =
     user_data.connection_established) AND
     (NOT(local_option_already_in_effect_or_being_negotiated(option))) THEN
        action_kind := tn_will ;
        send_option(action_kind, option) ;
        add_option_to_table(local_options_pending, option) ;
    ELSE
      add_option_to_table(local_options_desired, option) ;
    END IF ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rloe") ;
      RAISE ;
  END request_local_option_enable ; -- body


  PROCEDURE demand_local_option_disable -- body
            ---------------------------
   (option : IN user_data.option_type) IS

  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is already in effect,
  -- this procedure will negotiate the cessation of that
  -- option.  If there is no connection established, the desirable option
  -- tables will be updated and TELNET PPL will not try to negotiate this
  -- option at the establishment of a new connection.
  -----------------------------------------------------------------------------
  BEGIN
    IF (user_data.user_control_block.communication_state =
     user_data.connection_established) AND
     option_in_table(local_options_in_effect, option) THEN
       action_kind := tn_wont ;
       send_option(action_kind, option) ;
       add_option_to_table(local_options_pending, option) ;
    ELSE
      delete_option_from_table(local_options_desired, option) ;
    END IF ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.dlod") ;
      RAISE ;
  END demand_local_option_disable ; -- body


  PROCEDURE request_remote_option_enable -- body
            ----------------------------
   (option : IN user_data.option_type) IS

  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is not already in effect,
  -- this procedure will negotiate for that option.  Otherwise, the desirable
  -- option tables will be updated and TELNET PPL will try to negotiate these
  -- options at the establishment of a new connection.
  -----------------------------------------------------------------------------
  BEGIN
    IF (user_data.user_control_block.communication_state =
     user_data.connection_established) AND
     (NOT(remote_option_already_in_effect_or_being_negotiated(option))) THEN
        action_kind := tn_do ;
        send_option(action_kind, option) ;
        add_option_to_table(remote_options_pending, option) ;
    ELSE -- add to desired options table
      add_option_to_table(remote_options_desired, option) ;
    END IF ; -- not (in effect or in negotiation)
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rroe") ;
      RAISE ;
  END request_remote_option_enable ; -- body


  PROCEDURE demand_remote_option_disable -- body
            ----------------------------
   (option : IN user_data.option_type) IS

  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- If the connection is established and the option is already in effect,
  -- this procedure will negotiate the cessation of that
  -- option.  If there is no connection established, the desirable option
  -- tables will be updated and TELNET PPL will not try to negotiate this
  -- option at the establishment of a new connection.
  -----------------------------------------------------------------------------
  BEGIN
    IF (user_data.user_control_block.communication_state =
     user_data.connection_established) AND
     option_in_table(remote_options_in_effect, option) THEN
       action_kind := tn_dont ;
       send_option(action_kind, option) ;
       add_option_to_table(remote_options_pending, option) ;
    ELSE
      delete_option_from_table(remote_options_desired, option) ;
    END IF ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.drod") ;
      RAISE ;
  END demand_remote_option_disable ; -- body


  PROCEDURE negotiate_initial_desired_options -- body
            ---------------------------------
   IS
    -- ************************  BODY SPECIFICATION  **************************
    --
    -- This procedure will use the information contained in the desirable
    -- options tables to negotiate initial options with the remote TELNET
    -- connection.
    --
    -- Processing sequence...
    -- Check the table of remote options that are desired for the other end
    -- and send a DO OPTION --- through the connection for each.  Check the
    -- table of local options desirable on this end and send a WILL OPTION ---
    -- through the connection for each.
    ---------------------------------------------------------------------------

  BEGIN -- negotiate initial options procedure body
    action_kind := tn_do ;
    FOR index IN 1..remote_options_desired.number_of_items LOOP
      request_remote_option_enable
       (remote_options_desired.option(index)) ;
    END LOOP ;
    action_kind := tn_will ;
    FOR index IN 1..local_options_desired.number_of_items LOOP
      request_local_option_enable(local_options_desired.option(index)) ;
    END LOOP ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.nido") ;
      RAISE ;
  END negotiate_initial_desired_options ; -- procedure body


  PROCEDURE remote_will_received  -- body
            --------------------
   (option_code : IN bit_count_8_type) IS

  -- *************************  BODY SPECIFICATION  ***************************
  --
  -- If the option code is not supported, send a don't for the unknown code;
  -- otherwize process the option in the following manner.
  -- If we already asked for this option(in remote_options_pending table) then
  -- add it to the remote_options_in_effect table and remove it from the
  -- remote pending options table.
  -- Otherwize, if the option is in the remote_options_desired table then "ack"
  -- it and add it to the remote_options_in_effect table.
  -- If the above conditions were not met, then refuse to allow the option
  -- and "ack" it if required(option not in remote_option_pending table) or
  -- simply remove it from the remote_options_pending table if no "ack"
  -- is neccessary.
  -----------------------------------------------------------------------------
  BEGIN
    CASE option_code IS
      WHEN 1 => -- echo : note both sides cannot echo at once(=> loop forever)
        -- see RFC 857 for information on the TELNET echo option
        IF option_in_table(remote_options_pending, echo) AND
         (NOT(option_in_table(local_options_in_effect, echo))) THEN
          delete_option_from_table(remote_options_pending, echo) ;
          add_option_to_table(remote_options_in_effect, echo) ;
          store_message("$@$ remote echo option in effect $@$") ;
        ELSIF option_in_table(remote_options_desired, echo) AND
         (NOT(option_in_table(local_options_in_effect, echo))) THEN
          add_option_to_table(remote_options_in_effect, echo) ;
          store_message("$@$ remote echo option in effect $@$") ;
          action_kind := tn_do ;
          send_option(action_kind, echo) ;
        ELSE -- check if negative ack required
          store_message("$@$ remote echo option denied by local Telnet $@$") ;
          IF option_in_table(remote_options_pending, echo) THEN -- no ack
             delete_option_from_table(remote_options_pending, echo) ;
          ELSE -- send negative ack
            action_kind := tn_dont ;
            send_option(action_kind, echo) ;
          END IF ;
        END IF ;
      WHEN 3 => -- suppress go ahead
        -- see RFC 858 for information on the TELNET suppress ga option
        IF option_in_table(remote_options_pending, suppress_ga) THEN
          delete_option_from_table(remote_options_pending, suppress_ga) ;
          add_option_to_table(remote_options_in_effect, suppress_ga) ;
          store_message("$@$ remote suppress_ga option in effect $@$") ;
        ELSIF option_in_table(remote_options_desired, suppress_ga) THEN
          add_option_to_table(remote_options_in_effect, suppress_ga) ;
          store_message("$@$ remote suppress_ga option in effect $@$") ;
          action_kind := tn_do ;
          send_option(action_kind, suppress_ga) ;
        ELSE -- check if negative ack required
          store_message("$@$ remote suppress_ga option denied by local Telnet $@$") ;
          IF option_in_table(remote_options_pending, suppress_ga) THEN -- no ack
            delete_option_from_table(remote_options_pending, suppress_ga) ;
          ELSE -- send negative ack
            action_kind := tn_dont ;
            send_option(action_kind, suppress_ga) ;
          END IF ;
        END IF ;
      WHEN OTHERS => -- not supported, refuse offer
        action_kind := tn_dont ;
        send_option(action_kind, option_code) ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rwillr") ;
      RAISE ;
  END remote_will_received ;


  PROCEDURE remote_wont_received  -- body
            --------------------
   (option_code : IN bit_count_8_type) IS

  -- *************************  BODY SPECIFICATION  ***************************
  --
  -- If the code is suported then process as follows...
  -- If the option was requested remotly(item in remote_options_in_effect table
  -- and item not in remote_options_pending) then ack the wont with a dont.
  -- Remove the item from the romote_options_pending / in_effect tables
  -----------------------------------------------------------------------------

  BEGIN
    CASE option_code IS
      WHEN 1 => -- ECHO
        -- see RFC 857 for information on the TELNET echo option
        store_message("$@$ remote echo option denied by remote $@$") ;
        IF (option_in_table(remote_options_in_effect, echo)) AND
         (NOT(option_in_table(remote_options_pending, echo))) THEN -- ack
          action_kind := tn_dont ; -- ack
          send_option(action_kind, echo) ;
        END IF ;
        delete_option_from_table(remote_options_in_effect, echo) ;
        delete_option_from_table(remote_options_pending, echo) ;
      WHEN 3 => -- SUPPRESS_GA
        -- see RFC 858 for information on the TELNET suppress_ga option
        store_message("$@$ remote suppress_ga option denied by remote $@$") ;
        IF option_in_table(remote_options_in_effect, suppress_ga) AND
         (NOT(option_in_table(remote_options_pending, suppress_ga))) THEN -- ack
          action_kind := tn_dont ; -- ack
          send_option(action_kind, suppress_ga) ;
        END IF ;
        delete_option_from_table(remote_options_in_effect, suppress_ga) ;
        delete_option_from_table(remote_options_pending, suppress_ga) ;
      WHEN OTHERS => -- not supported, refuse offer
        NULL ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rwontr") ;
      RAISE ;
  END remote_wont_received ;


  PROCEDURE remote_do_received  -- body
            ------------------
   (option_code : IN bit_count_8_type) IS

  -- *************************  BODY SPECIFICATION  ***************************
  --
  -- If the option code is not supported, send a don't for the unknown code;
  -- otherwize process the option in the following manner.
  -- If we already asked for this option(in remote_options_pending table) then
  -- add it to the remote_options_in_effect table and remove it from the
  -- remote pending options table.
  -- Otherwize, if the option is in the remote_options_desired table then "ack"
  -- it and add it to the remote_options_in_effect table.
  -- If the above conditions were not met, then refuse to allow the option
  -- and "ack" it if required(option not in remote_option_pending table) or
  -- simply remove it from the remote_options_pending table if no "ack"
  -- is neccessary.
  -----------------------------------------------------------------------------
  BEGIN
    CASE option_code IS
      WHEN 1 => -- echo : note both sides cannot echo at once(=> loop forever)
        -- see RFC 857 for information on the TELNET echo option
        IF option_in_table(local_options_pending, echo) AND
         (NOT(option_in_table(remote_options_in_effect, echo))) THEN
           delete_option_from_table(local_options_pending, echo) ;
          add_option_to_table(local_options_in_effect, echo) ;
          store_message("$@$ local echo option in effect $@$") ;
        ELSIF option_in_table(local_options_desired, echo) AND
         (NOT(option_in_table(remote_options_in_effect, echo))) THEN
          add_option_to_table(local_options_in_effect, echo) ;
          action_kind := tn_will ;
          send_option(action_kind, echo) ;
          store_message("$@$ local echo option in effect $@$") ;
        ELSE -- check if negative ack required
          store_message("$@$ local echo option denied by local telnet $@$") ;
          IF option_in_table(remote_options_pending, echo) THEN
             delete_option_from_table(local_options_pending, echo) ;
          ELSE -- send negative ack
            action_kind := tn_wont ;
            send_option(action_kind, echo) ;
          END IF ;
        END IF ;
      WHEN 3 => -- suppress_ga
        -- see RFC 858 for information on the TELNET supress_ga option
        IF option_in_table(local_options_pending, suppress_ga) THEN
          delete_option_from_table(local_options_pending, suppress_ga) ;
          add_option_to_table(local_options_in_effect, suppress_ga) ;
          store_message("$@$ local suppress_ga option in effect $@$") ;
        ELSIF option_in_table(local_options_desired, suppress_ga) THEN
          store_message("$@$ local suppress_ga option in effect $@$") ;
          add_option_to_table(local_options_in_effect, suppress_ga) ;
          action_kind := tn_will ;
          send_option(action_kind, suppress_ga) ;
        ELSE -- check if negative ack required
          store_message("$@$ local suppress_ga option denied by local telnet $@$") ;
          IF option_in_table(remote_options_pending, suppress_ga) THEN
            delete_option_from_table(local_options_pending, suppress_ga) ;
          ELSE -- send negative ack
            action_kind := tn_wont ;
            send_option(action_kind, suppress_ga) ;
          END IF ;
        END IF ;
      WHEN OTHERS => -- not supported, refuse offer
        action_kind := tn_wont ;
        send_option(action_kind, option_code) ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rdor") ;
      RAISE ;
  END remote_do_received  ;


  PROCEDURE remote_dont_received  -- body
            --------------------
   (option_code : IN bit_count_8_type) IS

  -- *************************  BODY SPECIFICATION  ***************************
  --
  -- If the code is suported then process as follows...
  -- If the option was requested remotly(item in local_options_in_effect table
  -- and item not in local_options_pending) then ack the dont with a wont.
  -- Remove the item from the local_options_pending / in_effect tables
  -----------------------------------------------------------------------------

  BEGIN
    CASE option_code IS
      WHEN 1 => -- echo
        -- see RFC 857 for information on the TELNET echo option
        store_message("$@$ local echo option denied by remote $@$") ;
        IF option_in_table(local_options_in_effect, echo) AND
         (NOT(option_in_table(local_options_pending, echo))) THEN -- ack
          action_kind := tn_wont ; -- ack
          send_option(action_kind, echo) ;
        END IF ;
        delete_option_from_table(local_options_in_effect, echo) ;
        delete_option_from_table(local_options_pending, echo) ;
      WHEN 3 => -- suppress_ga
        -- see RFC 858 for information on the TELNET suppress_ga
        store_message("$@$ local suppress_ga option denied by remote $@$") ;
        IF option_in_table(local_options_in_effect, suppress_ga) AND
         (NOT(option_in_table(local_options_pending, suppress_ga))) THEN -- ack
          action_kind := tn_wont ; -- ack
          send_option(action_kind, suppress_ga) ;
        END IF ;
        delete_option_from_table(local_options_in_effect, suppress_ga) ;
        delete_option_from_table(local_options_pending, suppress_ga) ;
      WHEN OTHERS => -- should not get this
        NULL ;
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac.rdontr") ;
      RAISE ;
  END remote_dont_received  ;

BEGIN -- option_negotiation body
  echo := user_data.echo ; -- TeleSoft won't init this in declaration
  suppress_ga := user_data.suppress_ga ; -- ditto
-- packed agregates not impleminted yet
--  action_code := (251, 252, 253, 254) ; -- RFC 854 page 14
--  option_code := (1) ; -- RFC 857 page 1 (code for echo)
  action_code(tn_will) := 251 ;
  action_code(tn_wont) := 252 ;
  action_code(tn_do)   := 253 ;
  action_code(tn_dont) := 254 ;
  option_code(echo)        := 1 ;
  option_code(suppress_ga) := 3 ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN poptngpac instantiation") ;
      RAISE ;
END option_negotiation ; -- package_body
--::::::::::::::
--amesspac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01045-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         AMESSPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : amesspac

--   5/8/85  8:50 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

WITH SYSTEM ; -- to gain access to system.byte
WITH virtual_transport_level ;
WITH virtual_terminal ;
WITH user_data ; -- access the port_number

PACKAGE message_processing -- specfication
        ------------------
 IS

-- **********************  USER SPECIFICATION  ********************************
--
-- This package provides data types and subprograms for processing (at
-- the APL level)  messages from the transport level to TELNET for a
-- particular user. A message being information which originated at the
-- local transport level, not simply data being relayed from the remote
-- TELNET.  This information is given higher priority than simple
-- data transfer.
--
-- ****************************************************************************

--&MT SUBTYPE bit_count_16_type IS INTEGER ;
  SUBTYPE bit_count_16_type IS SHORT_INTEGER ;

  max_msg_length : CONSTANT bit_count_16_type :=
   virtual_transport_level.max_msg_length ;
-- make a deferred constant when supported

  SUBTYPE message_from_transport_level_type IS
   virtual_transport_level.message_type ;
-- Telelie ADA does not support limited private subtpes ;

  FUNCTION there_is_a_message_available -- specification
           ----------------------------
   RETURN BOOLEAN ;
    -- ************************  USER SPECIFICATION  ****************************
  --
  -- This function returns true if there is a message available from the
  -- transport level.
  -----------------------------------------------------------------------------


  PROCEDURE retrieve_message -- specification
            ----------------
   (message : OUT message_from_transport_level_type ;
    length  : OUT bit_count_16_type) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure gets an entire message from the transport level.
  -----------------------------------------------------------------------------


  PROCEDURE write_message_to_NVT_printer -- specification
            ----------------------------
   (transport_level_message : IN message_from_transport_level_type ;
    length                  : IN bit_count_16_type) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure writes an entire message from the transport level
  -- to the NVT printer.
  -----------------------------------------------------------------------------

END message_processing ; -- package specification
--::::::::::::::
--amesspac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01046-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         AMESSPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : amesspac

--   5/8/85  9:10 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

WITH debug_io ;

PACKAGE BODY message_processing IS
             ------------------

  FUNCTION there_is_a_message_available -- body
           ----------------------------
   RETURN BOOLEAN IS
  BEGIN
    RETURN virtual_transport_level.there_is_a_message ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac.there_is_msg") ;
      RAISE ;

  END there_is_a_message_available ; -- function body


  PROCEDURE retrieve_message -- body
            ----------------
   (message : OUT message_from_transport_level_type ;
    length  : OUT bit_count_16_type) IS
  BEGIN
    IF virtual_transport_level.there_is_a_message THEN
      virtual_transport_level.get_message(message, length) ;
    ELSE -- error
      length := 0 ; -- no message available, erronious call
    END IF ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac.retr_msg") ;
      RAISE ;

  END retrieve_message ; -- procedure body


  PROCEDURE write_message_to_NVT_printer -- body
            ----------------------------
   (transport_level_message : IN message_from_transport_level_type ;
    length  : IN bit_count_16_type) IS
  BEGIN
    FOR index IN 1..length LOOP
      virtual_terminal.output_character_to_nvt_printer
       (user_data.user_control_block.port, transport_level_message(index)) ;
    END LOOP ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac.write_msg_nvt") ;
      RAISE ;

  END write_message_to_NVT_printer ; -- procedure body

BEGIN
  NULL ;
EXCEPTION
  WHEN OTHERS =>
    debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN amesspac instantiation") ;
    RAISE ;

END message_processing ; -- package body
--::::::::::::::
--atrinpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01049-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ATRINPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : atrinpac

--   5/8/85  9:25 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

WITH SYSTEM ; -- to get access to system.byte

PACKAGE transport_level_input_processing -- specification
        --------------------------------
 IS
-- **************************  USER SPECIFICATION  ****************************
--
-- This package provides subprograms to process (at the APL level) data
-- input to TELNET relayed from the remote TELNET.
--
-- **************************************************************************

--&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 ;



  SUBTYPE character_type IS bit_count_8_type ;

  FUNCTION there_is_input -- specification
           --------------
   RETURN BOOLEAN ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This function returns true if there is data input available from the
  -- remote TELNET.
  -----------------------------------------------------------------------------


  PROCEDURE input_character -- specification
            ---------------
   (char :             OUT character_type ;
    control_function : OUT BOOLEAN ;
    urgent_data      : OUT BOOLEAN) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure returns a character sent from the remote TELNET and
  -- indicates whether it is to be interpreted as a control function.
  -----------------------------------------------------------------------------


  PROCEDURE process_standard_control_function -- specification
            ---------------------------------
   (char : IN character_type ;
    urgent_data : IN BOOLEAN) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure processes a control function which was received from
  -- the remote TELNET connection.
  -----------------------------------------------------------------------------


  PROCEDURE write_character_to_NVT_printer -- specification
            ------------------------------
   (char : IN character_type) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This routine writes a character to the NVT printer.
  -----------------------------------------------------------------------------

END transport_level_input_processing ; -- package specification


--::::::::::::::
--atrinpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01050-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ATRINPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : atrinpac

--   5/8/85  9:37 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

WITH virtual_transport_level ;
WITH virtual_terminal ;
WITH option_negotiation ;
WITH user_data ;
WITH debug_io ;

PACKAGE BODY transport_level_input_processing
             --------------------------------
 IS
-- *********************  BODY SPECIFICATION  *********************************
--
-- This package provides subprograms to process (at the APL level) data
-- input to TELNET from the transport level.  Make the appropriate calls
-- to the lower level APL packages which will in turn call routines from
-- the PPL.  Data input is data sent from the remote TELNET.
--
-- ****************************************************************************

  FUNCTION there_is_input -- body
           --------------
   RETURN BOOLEAN IS
  BEGIN
    RETURN virtual_transport_level.there_is_input ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.there_is_input") ;
      RAISE ;

  END there_is_input ; -- function body


  PROCEDURE input_character -- body
            ---------------
   (char :             OUT character_type ;
    control_function : OUT BOOLEAN ;
    urgent_data      : OUT BOOLEAN) IS
  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- This procedure returns a character sent from the remote TELNET
  -- and indicates whether it is to be interpreted as a control function.
  -- Characters which are part of a synch are flagged as a control function.
  -- The urgent data flag or the user_data.synch_in_progress = TRUE indicates
  -- that the current character is to be interpreted as a control function.
  -- If the character is an IAC(Interperate As Command), get another
  -- character.  If the second character is not an IAC it is a command and to
  -- be interpreted as a control function.  (This will also have the effect of
  -- of screening out the doubling of the IAC code done by the remote TELNET
  -- when it is not to be interpreted as an IAC, ie. the data byte 255.)
  -- A call to this procedure without checking for the presence of characters
  -- to input is erroneous but will result in char := 0 and control_function
  -- := FALSE.
  -----------------------------------------------------------------------------

    IAC : CONSTANT character_type := 255 ; -- interprate as command code
    temp_char : character_type;
    temp_control_function : BOOLEAN;
    temp_urgent_data : BOOLEAN;

  BEGIN
    temp_char := 0 ;
    temp_control_function := FALSE ;
    IF virtual_transport_level.there_is_input THEN
      virtual_transport_level.get_input(temp_char, temp_urgent_data) ;
      IF user_data.user_control_block.synch_is_in_progress
       OR temp_urgent_data THEN -- special handling required
        temp_control_function := TRUE ;
        debug_io.put("atrinpac.input_character: control func detected, code=") ;
        debug_io.put_line_byte(temp_char) ;
      END IF ;
      IF bit_count_16_type(temp_char) = bit_count_16_type(IAC) THEN
        WHILE NOT(virtual_transport_level.there_is_input) LOOP NULL ; END LOOP ;
        virtual_transport_level.get_input(temp_char, temp_urgent_data) ;
        IF bit_count_16_type(temp_char) /= bit_count_16_type(IAC) THEN -- command IAC
          temp_control_function := TRUE ;
        END IF ;
      END IF ;
    END IF ;

    char := temp_char;
    control_function := temp_control_function;
    urgent_data := temp_urgent_data;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.input_chr") ;
      RAISE ;

  END input_character ; -- procedure body


  PROCEDURE process_standard_control_function -- body
            ---------------------------------
   (char : IN character_type ;
    urgent_data : IN BOOLEAN)
   IS
  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- This procedure processes a control function which was received from
  -- the remote TELNET.  Handling of the TELNET synch mechanism is also done
  -- here as follows.  The synch is sent via the transport level send
  -- operation with the urgent flag set and the data mark (DM) as the last
  -- (or only) data octet.  If the transport level urgent data flag is set,
  -- the data stream is scanned for IP, AO, AYT, and DM signals.
  -- When in normal mode, the DM is a no-op; when in urgent mode, it signals
  -- the end of urgent processing.  If the transport level indicates the end
  -- of urgent data before the DM is found, TELNET will continue special
  -- handling of the data stream until the DM is found. If more urgent data is
  -- indicated after the DM is found, TELNET will continue special handling
  -- of the data stream until the DM is found.  NOTE: Site dependent code used
  -- for the IP and BREAK commands.
  -- See RFC 854, page 9 for details on the TELNET synch mechanism.
  -----------------------------------------------------------------------------

    option_code      : bit_count_8_type ;
    control_function : BOOLEAN ;
    urgent_flag      : BOOLEAN ;
    urgent           : CONSTANT BOOLEAN := TRUE ;
    not_urgent       : CONSTANT BOOLEAN := FALSE ;

  BEGIN -- process_standard_control_function

    debug_io.put_line("begin atrinpac.process_standard_control_function") ;
    IF user_data.user_control_block.synch_is_in_progress THEN
      debug_io.put("synch is in progress,") ;
    ELSE
      debug_io.put("synch is NOT in progress,") ;
    END IF ;
    IF urgent_data THEN
      debug_io.put("   urgent data,") ;
    ELSE
      debug_io.put("   NOT urgent data,") ;
    END IF ;
    debug_io.put("   char_code=") ;
    debug_io.put_line_byte(char) ;

    IF user_data.user_control_block.synch_is_in_progress OR urgent_data THEN
      user_data.user_control_block.synch_is_in_progress := TRUE ;
    END IF ;
      CASE char IS -- handle non synch char
        WHEN 240 | 241 | 250 => -- SE, NOP, SB (RFC 854, p. 14)
          NULL ; -- nop for now
        WHEN 242 => -- DM
          user_data.user_control_block.synch_is_in_progress := FALSE ;
        WHEN 243 => -- break ****** NOTE: SITE DEPENDENT CODE USED ******
          virtual_terminal.output_character_to_nvt_printer
           (user_data.user_control_block.port, 3) ; -- ctrl c for VAX
        WHEN 244 => -- IP  ****** NOTE: SITE DEPENDENT CODE USED ******
          virtual_terminal.output_character_to_nvt_printer
           (user_data.user_control_block.port, 25) ; -- ctrl y for VAX
        WHEN 245 => -- AO
          DECLARE -- (RFC 854, P. 7,8,&14)
            buffer : user_data.string_type(1..user_data.max_out_string) ;
            length : bit_count_16_type ;
            data_mark : virtual_transport_level.info_output_type(1..1) ;
          BEGIN -- declare
            data_mark(1) := 242 ;
            user_data.get_data_buffer(buffer, length) ; -- trash rest of buffer
            virtual_transport_level.send_data(data_mark, urgent) ; -- synch
          END ; -- declare
        WHEN 246 => -- AYT   (RFC 854, P. 13,14)
          DECLARE
            ayt_responce     : STRING(1..12) := " I AM HERE. " ;
            ayt_responce_vtl : virtual_transport_level.info_output_type(1..12);
          BEGIN -- delcare
            ayt_responce(1) := ASCII.CR ;
            ayt_responce(12) := ASCII.CR ;
            FOR index IN ayt_responce'RANGE LOOP -- convert type
              ayt_responce_vtl(bit_count_16_type(index)) :=
               bit_count_8_type(CHARACTER'POS(ayt_responce(index))) ;
            END LOOP ;
            virtual_transport_level.send_data(ayt_responce_vtl, not_urgent) ;
          END ; -- declare
        WHEN 247 => -- EC  (RFC 854, P. 13,14)
          IF user_data.there_is_data_in_data_buffer AND
            user_data.user_control_block.synch_is_in_progress = FALSE THEN
            DECLARE
              buffer : user_data.out_string_type ;
              length : bit_count_16_type RANGE 1..user_data.max_out_string ;
            BEGIN -- declare
              user_data.get_data_buffer(buffer, length) ;
              user_data.put_string_in_data_buffer(buffer(1..length - 1)) ;
            END ; -- declare
          END IF ;
        WHEN 248 => -- EL
          IF user_data.there_is_data_in_data_buffer AND
            user_data.user_control_block.synch_is_in_progress = FALSE THEN
            DECLARE
              buffer : user_data.out_string_type ;
              length : bit_count_16_type RANGE 1..user_data.max_out_string ;
            BEGIN -- declare
              user_data.get_data_buffer(buffer, length) ;
              FOR index IN REVERSE 1..length LOOP -- delete up to CRLF
                IF bit_count_16_type(buffer(index)) = 10 THEN -- line feed
                  IF index > 1 AND THEN
                    bit_count_16_type(buffer(index - 1)) = 13 THEN -- cr
                    user_data.put_string_in_data_buffer(buffer(1..index)) ;
                    EXIT ; -- loop
                  END IF ; -- CR?
                END IF ; -- LF?
              END LOOP ; -- delete up to CRLF
            END ; -- declare
          END IF ; -- data in buffer and no synch in progress?
        WHEN 249 => -- GA
          user_data.user_control_block.ga_received := TRUE ;
        WHEN 251 => -- WILL (option code)
          -- get option code
          WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ;
          END LOOP ;
          virtual_transport_level.get_input(option_code, urgent_flag) ;
          option_negotiation.remote_will_received(option_code) ;
        WHEN 252 => -- WON'T (option code)
          -- get option code
          WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ;
          END LOOP ;
          virtual_transport_level.get_input
           (option_code, urgent_flag) ;
          option_negotiation.remote_wont_received(option_code) ;
        WHEN 253 => -- DO (option code)
          -- get option code
          WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ;
          END LOOP ;
          virtual_transport_level.get_input(option_code, urgent_flag) ;
          option_negotiation.remote_do_received(option_code) ;
        WHEN 254 => -- DON'T (option code)
          -- get option code
          WHILE NOT (virtual_transport_level.there_is_input) LOOP NULL ;
          END LOOP ;
          virtual_transport_level.get_input(option_code, urgent_flag) ;
          option_negotiation.remote_dont_received(option_code) ;
        WHEN OTHERS => -- error
          NULL ;
      END CASE ; -- handle non synch char
    debug_io.put_line("begin atrinpac.process_standard_control_function") ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.proc_std_cf") ;
      debug_io.put("char=") ;
      debug_io.put_line_byte(char) ;
      RAISE ;

  END process_standard_control_function ; -- procedure body


  PROCEDURE write_character_to_NVT_printer -- body
            ------------------------------
   (char : IN character_type) IS
  BEGIN
    virtual_terminal.output_character_to_nvt_printer
    (user_data.user_control_block.port, char) ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.write_chr") ;
      RAISE ;
  END write_character_to_NVT_printer ; -- procedure body

BEGIN
  NULL ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac instantiation") ;
      RAISE ;

END transport_level_input_processing ; -- package body
--::::::::::::::
--akeybdpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01043-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         AKEYBDPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------


-- File : akeybdpac

--   5/8/85  1:15 PM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--   5/23/85 8:31 AM : MODIFY FOR TELESOFT        AUTHOR : MIKE THOMAS
--                     OLD CODE (DEC) MARKED AS --&MT

--   5/23/85 10:09 AM : MODIFY FOR DEC ADA        AUTHOR : MIKE THOMAS
--                      OLD CODE (TELESOFT)  MARKED AS --&MT

WITH SYSTEM ; -- for access to system.byte
USE SYSTEM ;

PACKAGE nvt_keyboard_input_processing -- specification
        -----------------------------
 IS
-- ************************  USER SPECIFICATION  ******************************
--
-- This package provides subprograms to allow APL level processing of data
-- entered into the Network Virtual Terminal (NVT) for a particular user of
-- TELNET.
--
-- ****************************************************************************

--&MT   SUBTYPE bit_count_8_type IS SYSTEM.BYTE ;
  SUBTYPE bit_count_8_type IS SYSTEM.UNSIGNED_BYTE ;

  SUBTYPE character_type IS bit_count_8_type ;

  FUNCTION there_is_input_from_the_NVT_keyboard
           ------------------------------------
   RETURN BOOLEAN ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This function returns true if there is input from the NVT keyboard.
  -----------------------------------------------------------------------------


  PROCEDURE get_a_character
            ---------------
   (char : OUT character_type ;
    the_char_is_a_control_function : OUT BOOLEAN) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This routine returns a logical character from the NVT keyboard and
  -- indicates whether the character is to be interpreted as a control
  -- function or data.
  -----------------------------------------------------------------------------



  PROCEDURE process_standard_control_function_from_keyboard
            -----------------------------------------------
   (char : IN character_type) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will perform the appropriate action for the specified
  -- control function.
  -----------------------------------------------------------------------------


  PROCEDURE process_partial_command
            -----------------------
   (char : IN character_type) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will process the character as part of a parital command.
  -----------------------------------------------------------------------------


  PROCEDURE put_character_in_data_buffer
            ----------------------------
   (char : IN character_type) ;
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will put a character into the APL keyboard data buffer.
  -----------------------------------------------------------------------------


  PROCEDURE send_data_buffer_to_transport_level ;
            -----------------------------------
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will send the entire contents of the APL keyboard data
  -- buffer to the transport level for transmission to the remote TELNET.
  -----------------------------------------------------------------------------


END nvt_keyboard_input_processing ; -- specification

--::::::::::::::
--akeybdpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01044-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         AKEYBDPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------


-- File : akeybdpac

--   5/8/85  1:35 PM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--   5/23/85 8:31 AM : MODIFY FOR TELESOFT        AUTHOR : MIKE THOMAS
--                     OLD CODE (DEC) MARKED AS --&MT

--   5/23/85  2:09 PM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                      OLD CODE (TELESOFT) MARKED AS --&MT
--   6/23/85  9:08 PM : set ga_received = false in send_data_buffer
--    6/1/85  1:12 PM : add quit option commands, remove status var from opt reqs

WITH virtual_terminal ;
WITH virtual_transport_level ;
WITH option_negotiation ;
WITH user_data ;
USE user_data ;
WITH debug_io ; -- for test debug


PACKAGE BODY  nvt_keyboard_input_processing 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 ;

  FUNCTION there_is_input_from_the_NVT_keyboard
           ------------------------------------
   RETURN BOOLEAN IS
  BEGIN
    RETURN virtual_terminal.there_are_characters_in_keyboard_buffer
     (user_data.user_control_block.port) ;
  END there_is_input_from_the_NVT_keyboard ;


  PROCEDURE get_a_character
            ---------------
   (char : OUT character_type ;
    the_char_is_a_control_function : OUT BOOLEAN) IS

    temp_char : character_type ;
    temp_the_char_is_a_control_function : BOOLEAN ;

    PROCEDURE determine_if -- control function?
              ------------
     (the_char_is_a_control_function : OUT BOOLEAN ;
      char                           : IN  bit_count_8_type) IS --TBD
    BEGIN
      the_char_is_a_control_function := FALSE ; -- add real check later(TBD)
    END determine_if ;

  BEGIN
    virtual_terminal.get_next_character_from_keyboard_buffer
     (user_data.user_control_block.port, temp_char) ;
    determine_if(temp_the_char_is_a_control_function, temp_char) ;
    char := temp_char ;
    the_char_is_a_control_function := temp_the_char_is_a_control_function ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_a_char") ;
      RAISE ;
  END get_a_character ;


  PROCEDURE process_standard_control_function_from_keyboard
            -----------------------------------------------
   (char : IN character_type) IS

  IAC : bit_count_8_type := 255 ; -- interprate as command
  no_partial_command : user_data.command_state_type ;
  urgent : BOOLEAN := TRUE ; -- tcp urgent flag
  command_bytes : virtual_transport_level.info_output_type(1..2) ;

  BEGIN
    no_partial_command := user_data.no_partial_command ;
    CASE char IS -- page 14 of RFC 854
      WHEN 242..249 => -- Break, IP, AO, AYT, EC, EL, GA,
        -- put in data buffer or command buffer baised on command state
        IF user_data.user_control_block.command_state = no_partial_command THEN
          put_character_in_data_buffer(IAC) ;
          put_character_in_data_buffer(char) ;
        ELSE -- partial command (EC, EL handled loacaly, rest==>"bad")
          process_partial_command(char) ;
        END IF ; -- not a partial command
      WHEN OTHERS =>
        NULL ; -- T B D  error condition
    END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.proc_std_cont_f") ;
      RAISE ;
  END process_standard_control_function_from_keyboard ;


  PROCEDURE process_partial_command
            -----------------------
   (char : IN character_type) IS
  -- ************************  BODY SPECIFICATION  ****************************
  --
  -- This procedure will process the character as part of a partial command.
  --
  -- Processing sequence...
  --
  -- If the character is not an end-of-line, add the character to the
  -- partial command buffer.  If the character is an end-of-line, the
  -- command will be parsed for semantics and the appropriate call will
  -- be made to the presentation level which will convert the desired
  -- action into the syntax of a call to the actual transport level.  Whether
  -- or not the complete command was entered properly, the command state
  -- will be set to no-partial-command.

-------------------------------------------------------------------------------
-- *** run-time compiler error: the initialization part of the declaration
--
--     does not happen at run time.  If the initialization is done explicitly
--     in the body part, the variable will be properly set.  Will just use
--     fully qualified name in body part.  TeleHosed again.
--
--    no_partial_command : user_data.command_state_type := no_partial_command ;
-------------------------------------------------------------------------------

    ------------------------  subprogram declarations  ------------------------

    PROCEDURE add_the_character_to_the_partial_command_buffer
              -----------------------------------------------
     (char : IN character_type) IS
    -- ***************************  SPECIFICATION  ****************************
    --
    -- This procedure will place a character into the partial command buffer.
    -- If the character is an erase character or erase line then remove
    -- one or all of the characters.  If all the characters have been
    -- erased, set the command_state to no_partial_command.
    ---------------------------------------------------------------------------

    command_buffer      : user_data.out_string_type ;
--&MT SUBTYPE length_type IS bit_count_16_type RANGE 1..user_data.max_out_string ;
     --&MT the above line caused a constraint error ; use the next line instead
    SUBTYPE length_type IS bit_count_16_type RANGE 0..user_data.max_out_string ;
    length              : length_type ;
    no_partial_command  : user_data.command_state_type ;
    slash               : CONSTANT bit_count_8_type := 16#2F# ; -- '/'
    E                   : CONSTANT bit_count_8_type := 16#45# ; -- 'E'
    L                   : CONSTANT bit_count_8_type := 16#4C# ; -- 'L'
    B                   : CONSTANT bit_count_8_type := 16#42# ; -- 'B'
    A                   : CONSTANT bit_count_8_type := 16#41# ; -- 'A'
    D                   : CONSTANT bit_count_8_type := 16#44# ; -- 'D'
    bell                : CONSTANT bit_count_8_type := 16#07# ; -- '^G'
    cr                  : CONSTANT bit_count_8_type := 16#0D# ; -- 'carrage return'
    lf                  : CONSTANT bit_count_8_type := 16#0A# ; -- 'line feed'
    not_control_char    : BOOLEAN := FALSE ;
    BEGIN -- add_the_character_to_the_partial_command_buffer
      no_partial_command := user_data.no_partial_command ;
      CASE char IS -- page 14 of RFC 854
        WHEN 247 | 248 => -- EC, EL
          IF user_data.there_is_data_in_command_buffer THEN
            user_data.get_command_buffer(command_buffer, length) ;
            IF char = 247 THEN -- EC
              -- put all but one back into the buffer
              FOR index IN 1..length-1 LOOP
                user_data.put_char_in_command_buffer(command_buffer(index)) ;
              END LOOP ;
              -- show character was deleted on nvt printer
              -- could be more eligant later on
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, slash) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, command_buffer(length)) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, slash) ;
              length := length - 1 ;
            ELSE -- EL
              -- show line was deleted on nvt printer
              -- could be more eligant later on
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, slash) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, E) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, L) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, slash) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, cr) ;
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, lf) ;
              length := 0 ;
            END IF ; -- EC or EL ?
            IF length = 0 THEN
              user_data.user_control_block.command_state :=
               no_partial_command ;
            END IF ; -- length = 0?
          END IF ; -- data in command buffer?
        WHEN 242 | 243 | 244 | 245 | 246 | 249 =>
        -- not EC or EL control function ==> not allowed in command string
          user_data.user_control_block.command_state := no_partial_command ;
          virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, B) ;
          virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, A) ;
          virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, D) ;
          virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, bell) ;
          virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, cr) ;
          virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, lf) ;
        WHEN OTHERS => -- non-control function
          user_data.put_char_in_command_buffer(char) ;
      END CASE ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.add_char_to_pcb") ;
      RAISE ;
    END add_the_character_to_the_partial_command_buffer ;


    PROCEDURE
     parse_command_buffer_for_semantics_and_make_call_to_presentation_level
     ----------------------------------------------------------------------
     IS
    -- **********************  USER SPECIFICATION  ****************************
    --
    -- This procedure will examine the command buffer and make the proper
    -- PPL procedure call to carry out that command action.
    ---------------------------------------------------------------------------

      command : user_data.out_string_type ;
      SUBTYPE length_type IS bit_count_16_type  RANGE 1..user_data.max_cmd_length ;
      length : length_type ;

      command_string : STRING (1..bit_count_32_type(user_data.max_cmd_length)) ;
      --&MT command_string : STRING (1..user_data.max_cmd_length) ;

      successful : BOOLEAN ;
      TYPE command_type IS (open_command, close_command, status_command,
       reset_command, echo_local_command, echo_remote_command,
       suppress_ga_local_command, suppress_ga_remote_command,
       send_abort_output_command, send_are_you_there_command,
       send_break_command, send_erase_character_command,
       send_erase_line_command, send_interrupt_process_command,
       send_sync_command, quit_echo_local_command, quit_echo_remote_command,
       quit_suppress_ga_local_command, quit_suppress_ga_remote_command,
       bad_command) ;
      type_of_command : command_type ;
      not_urgent : BOOLEAN := FALSE ; -- tcp urgent flag
      urgent : BOOLEAN := TRUE ; -- tcp urgent flag
      command_bytes : virtual_transport_level.info_output_type(1..2) ;
      not_control_characters : BOOLEAN := FALSE ;
      TYPE bytes_type IS ARRAY (bit_count_16_type RANGE <>) OF bit_count_8_type ;

      address_length      : bit_count_32_type ; -- open address parameter string length
      --&MT address_length      : bit_count_16_type ;

      network_number      : bit_count_16_type ; -- open parameters
      host_number         : bit_count_16_type ;
      logical_host_number : bit_count_16_type ;
      imp_number          : bit_count_16_type ;
      port_number         : bit_count_16_type ;

      PROCEDURE determine_command_type
                ----------------------
       (command_string_in  : IN STRING ;

        length             : IN bit_count_32_type ;
        --&MT   length             : IN bit_count_16_type ;

        type_of_command    : OUT command_type) IS
      -- *************************  SPECIFICATION  ****************************
      --
      -- This procedure will examine the command string and determine type
      -- of command.  In the case of an 'open' command, the parameters
      -- will be set to the correct values.
      -------------------------------------------------------------------------

        command_string : STRING(1..length + 3) ; -- make room for future padding
        ok : BOOLEAN ;

        PROCEDURE strip_off_extra_characters
                  --------------------------
         (item : IN OUT STRING ;

          string_length : IN OUT bit_count_32_type) IS
          --&MT     string_length : IN OUT bit_count_16_type) IS

        -- *************************  SPECIFICATION  **************************
        --
        -- This procedure returns a string in which the first four characters
        -- are comprised of the first character of each word in the command.
        -- If less than three words are in the command the missing word's
        -- position(s) are padded with blanks.  If the command was an OPEN,
        -- the remainder of the string is the OPEN address.
        -----------------------------------------------------------------------

          kept_pos : bit_count_32_type RANGE 1..string_length + 3 := 1 ; -- see below
--&MT     kept_pos : bit_count_16_type RANGE 1..string_length + 3 := 1 ;

          kept_buffer : STRING (1..string_length + 3) ; -- allow for padding bl
          store_char : BOOLEAN := FALSE ;
          -- open address starting location

          adr_start_pos : bit_count_32_type RANGE 1..string_length ;
--&MT     adr_start_pos : bit_count_16_type RANGE 1..string_length ;

        BEGIN -- strip off extra characters
          debug_io.put("in strip off extra characters, item=") ;
          debug_io.put(item(1..string_length)) ;
          debug_io.put("  string_length=") ;
          debug_io.put_line(bit_count_16_type(string_length)) ;
          IF item(2) = 'O' OR item(2) = 'o' THEN -- open (has parameters) (remove '@')
            debug_io.put_line("open detected") ;
            kept_buffer(1..4) :="O   " ; -- pad
            kept_pos := 4 ;
            FOR index IN 3..string_length LOOP  -- skip any extra letters
              IF item(index) = ' ' THEN -- end of "open", start of address
                adr_start_pos := index + 1 ;
                EXIT ; -- skip any extra characters loop
              END IF ;
            END LOOP ; -- skip
            FOR index IN adr_start_pos..string_length LOOP -- copy address
              kept_pos := kept_pos + 1 ;
              kept_buffer(kept_pos) := item(index) ;
            END LOOP ;
            string_length := kept_pos ;
            debug_io.put_line("open processed") ;
          ELSE --(no parameters)
            debug_io.put_line("non-open detected") ;
            kept_buffer(1) := item(2) ; -- remove '@'
            FOR item_pos IN 3..string_length LOOP
              debug_io.put("item_pos=") ;
              debug_io.put(bit_count_16_type(item_pos)) ;
              debug_io.put(" item(item_pos)=") ;
              debug_io.put_line(item(item_pos)) ;
              IF item(item_pos) = ' ' THEN -- delimiter
                store_char := TRUE ;
              ELSE -- non blank
                IF store_char THEN
                  kept_pos := kept_pos + 1 ;
                  kept_buffer(kept_pos) := item(item_pos) ;
                  store_char := FALSE ;
                END IF ; -- store char?
              END IF ; -- blank character?
            END LOOP ; -- examine all positions
            FOR pad_pos IN kept_pos+1..4 LOOP -- pad with blanks
               kept_pos := kept_pos + 1 ;
               kept_buffer(pad_pos) := ' ' ;
            END LOOP ; -- pad
            string_length := 0 ; -- no params
          END IF ; -- item(1) = 'O'?
          item(1..kept_pos) := kept_buffer(1..kept_pos) ;
          debug_io.put("leaving strip off extra characters, item=") ;
          debug_io.put(item(1..kept_pos)) ;
          debug_io.put(" string_length=") ;
          debug_io.put_line(bit_count_16_type(string_length)) ;
        EXCEPTION
          WHEN OTHERS =>
            debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.strip_ex") ;
            RAISE ;
        END strip_off_extra_characters ;


        PROCEDURE process_open_command_parameters IS
                  -------------------------------
          good_number : BOOLEAN ; -- true if number-to-string convert ok

          PROCEDURE strip_command_to_address
                    ------------------------
           (command_string : IN OUT STRING ;

            address_length : IN OUT bit_count_32_type) IS
--&MT       address_length : IN OUT bit_count_16_type) IS

          -- this procedure strips the leading 'O' and blanks from the
          -- command string

            SUBTYPE string_position_type IS

        bit_count_32_type RANGE 0..bit_count_32_type(user_data.max_cmd_length) ;
--&MT   bit_count_16_type RANGE 0..bit_count_16_type(user_data.max_cmd_length) ;

            com_pos : string_position_type ;

            com_buf : STRING (1..bit_count_32_type(user_data.max_cmd_length)) ;
--&MT       com_buf : STRING (1..user_data.max_cmd_length) ;

            buf_pos : string_position_type := 0 ;

          BEGIN -- strip_command_to_address
            debug_io.put_line("in strip_command_to_address") ;
            debug_io.put(" address_length=") ;
            debug_io.put_line(bit_count_16_type(address_length)) ;

            FOR com_pos IN 2..address_length LOOP
              IF command_string(com_pos) /= ' ' THEN
                buf_pos := buf_pos + 1 ;
                com_buf(buf_pos) := command_string(com_pos) ;
              END IF ;
            END LOOP ;
            command_string(1..buf_pos) := com_buf(1..buf_pos) ;
            debug_io.put("command string=") ;
            debug_io.put_line(command_string(1..buf_pos)) ;
            address_length := buf_pos ;
            debug_io.put("address_length=") ;
            debug_io.put_line(bit_count_16_type(address_length)) ;
            debug_io.put_line("end strip_command_to_adress") ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.strip_addr") ;
              RAISE ;
          END strip_command_to_address ;


          PROCEDURE convert_string_to_integer -- author : Mark Volpe
           (input_string  : IN  STRING ;
            integer_value : OUT bit_count_16_type ;
            status        : OUT BOOLEAN) IS

            next_value       : bit_count_16_type  := 0 ;
            power_of_ten     : bit_count_16_type  := 1 ;
            character_offset : bit_count_16_type  := CHARACTER'POS('0') ;

            temp_integer_value : bit_count_16_type := 0 ;
            temp_status : BOOLEAN := TRUE ;

          BEGIN
            FOR index IN REVERSE INPUT_STRING'RANGE LOOP
              IF (input_string(index)<'0') OR (input_string(index)>'9') THEN
                temp_status := FALSE ;
              EXIT ; -- loop
              END IF ;
              IF CHARACTER'POS(input_string(index))-character_offset = 0 THEN
                NULL ;
              ELSIF power_of_ten >
                ((bit_count_16_type'LAST - temp_integer_value) /
                 (CHARACTER'POS(input_string(index)) -
                 character_offset)) THEN
                temp_status := FALSE ;
                EXIT ; -- loop
              ELSE
                temp_integer_value := temp_integer_value +
                 (CHARACTER'POS(input_string(index)) -
                 character_offset) *
                 power_of_ten ;
              END IF ;
              power_of_ten := power_of_ten * 10 ;
            END LOOP ;
            integer_value := temp_integer_value ;
            status := temp_status ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.conv_s_i") ;
              RAISE ;
          END convert_string_to_integer ;


          PROCEDURE get_port_number
                    ---------------
           (address    : IN     STRING ;

            length     : IN OUT bit_count_32_type ;
--&MT       length     : IN OUT bit_count_16_type ;

            status_ok  :    OUT BOOLEAN) IS
          BEGIN -- get port number
            debug_io.put_line("in get port number") ;
            port_number := 23 ; -- default port number:RFC 854,page 15
            status_ok := TRUE ;
            FOR index IN REVERSE 1..length LOOP
              IF address(index) = ';' THEN -- port number specified
                convert_string_to_integer(address(index+1..length),
                 port_number, status_ok) ;
                length := index - 1 ; -- length of remaining address string
                EXIT ; -- LOOP
              END IF ; -- ';'?
            END LOOP ;
            debug_io.put("port #=") ;
            debug_io.put_line(port_number) ;
            debug_io.put("length=") ;
            debug_io.put_line(bit_count_16_type(length)) ;
            debug_io.put_line("end get port number") ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_port") ;
              RAISE ;
          END get_port_number ;


          PROCEDURE get_next_number -- get next # from address string
                    ---------------
           (address   : IN     STRING ;

            length    : IN OUT bit_count_32_type ;
--&MT       length    : IN OUT bit_count_16_type ;

            number    :    OUT bit_count_16_type ;
            ok        :    OUT BOOLEAN) IS

            temp_number : bit_count_16_type ;
            temp_ok : BOOLEAN ;
            SUBTYPE string_position_type IS
             bit_count_16_type RANGE 0..user_data.max_cmd_length ;

            buf_pos : bit_count_32_type := 0 ;
--&MT       buf_pos : bit_count_16_type := 0 ;

            num_buf : STRING (1..bit_count_32_type(user_data.max_cmd_length)) ;
--&MT       num_buf : STRING (1..user_data.max_cmd_length) ;

            delimiter : CHARACTER := '.' ;

            delimiter_found : bit_count_32_type RANGE 0..1 := 0 ;
--&MT       delimiter_found : bit_count_16_type RANGE 0..1 := 0 ;

            num_digits : bit_count_32_type RANGE 0..5 := 0 ;
--&MT       num_digits : bit_count_16_type RANGE 0..5 := 0 ;

          BEGIN -- get next number
            debug_io.put_line("in get next number") ;
            debug_io.put("address=") ;
            debug_io.put_line(address(1..length)) ;
            debug_io.put("length=") ;
            debug_io.put_line(bit_count_16_type(length)) ;
            temp_ok := TRUE ;
            FOR add_pos IN REVERSE 1..length LOOP -- find rightmost #
              IF address(add_pos) = delimiter THEN
                delimiter_found := 1 ; -- subtract 1 from final length of string
                EXIT ; -- loop
              ELSE
                num_digits := num_digits + 1 ;
              END IF ;
            END LOOP ;
            FOR add_pos IN length-num_digits+1..length LOOP -- get number
              buf_pos := buf_pos + 1 ;
              num_buf(buf_pos) := address(add_pos) ;
            END LOOP ;
            IF num_digits /= 0 THEN
              convert_string_to_integer(num_buf(1..num_digits), temp_number, temp_ok) ;
            ELSE -- set to a default of zero
              temp_number := 0 ;
            END IF ;
            length := length - num_digits - delimiter_found ;
            debug_io.put_line("after processing...") ;
            debug_io.put("length=") ;
            debug_io.put_line(bit_count_16_type(length)) ;
            IF temp_ok THEN
              debug_io.put("number=") ;
              debug_io.put_line(temp_number) ;
            END IF ;
            number := temp_number ;
              ok := temp_ok ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_num") ;
              RAISE ;
          END get_next_number ;


          PROCEDURE get_imp_number
                    --------------
           (address    : IN     STRING ;

            length     : IN OUT bit_count_32_type ;
--&MT       length     : IN OUT bit_count_16_type ;

            status_ok  :    OUT BOOLEAN) IS

            temp_status_ok : BOOLEAN ;

          BEGIN -- get imp number
            debug_io.put_line("in get imp #") ;
            get_next_number(address, length, imp_number, temp_status_ok) ;
            debug_io.put("imp_number=") ;
            debug_io.put_line(imp_number) ;
            IF imp_number = 0 THEN -- no imp number given, no default allowed
              temp_status_ok := FALSE ;
            END IF ;
            debug_io.put_line("end get imp #") ;
            status_ok := temp_status_ok ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_imp") ;
              RAISE ;
         END get_imp_number ;


          PROCEDURE get_logical_host_number
                    -----------------------
           (address    : IN OUT STRING ;

            length     : IN OUT bit_count_32_type ;
--&MT       length     : IN OUT bit_count_16_type ;

            status_ok  :    OUT BOOLEAN) IS

             temp_status_ok : BOOLEAN ;
          BEGIN -- get logical host number
            debug_io.put_line("in get logical host #") ;
            get_next_number
             (address, length, logical_host_number, temp_status_ok) ;
            debug_io.put("logical_host_number=") ;
            debug_io.put_line(logical_host_number) ;
            debug_io.put_line("end get logical host #") ;
            status_ok := temp_status_ok ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_lhost") ;
              RAISE ;
          END get_logical_host_number ;


          PROCEDURE get_host_number
                    ---------------
           (address    : IN OUT STRING ;

            length     : IN OUT bit_count_32_type ;
--&MT       length     : IN OUT bit_count_16_type ;

            status_ok  :    OUT BOOLEAN) IS

            temp_status_ok : BOOLEAN ;

          BEGIN -- get host number
            debug_io.put_line("in get_host_#") ;
            get_next_number(address, length, host_number, temp_status_ok) ;
            debug_io.put("host #=") ;
            debug_io.put_line(host_number) ;
            debug_io.put_line("end get_host_#") ;
            status_ok := temp_status_ok ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_host") ;
              RAISE ;
          END get_host_number ;


          PROCEDURE get_network_number
                    ------------------
           (address    : IN OUT STRING ;

            length     : IN OUT bit_count_32_type ;
--&MT       length     : IN OUT bit_count_16_type ;

            status_ok  :    OUT BOOLEAN) IS

            temp_status_ok : BOOLEAN ;

          BEGIN -- get network number
            debug_io.put_line("in get_network_#") ;
            get_next_number(address, length, network_number, temp_status_ok) ;
            IF network_number = 0 THEN -- use default
              network_number := 10 ; -- arpanet
            END IF ;
            debug_io.put("network #=") ;
            debug_io.put_line(network_number) ;
            debug_io.put_line("in get_network_#") ;
            status_ok := temp_status_ok ;
          EXCEPTION
            WHEN OTHERS =>
              debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.get_net") ;
              RAISE ;
          END get_network_number ;

        BEGIN -- process_open_command_parameters
          debug_io.put_line("in process_open_command_parameters") ;
          debug_io.put_line("pre strip") ;
          strip_command_to_address(command_string(1..address_length),
           address_length) ;
          debug_io.put_line("post strip, pre get_port_#") ;
          get_port_number(command_string, address_length, ok) ;
          debug_io.put_line("post get_port_#") ;
          IF ok THEN
            debug_io.put_line("pre get imp#") ;
            get_imp_number(command_string(1..address_length),
             address_length, ok) ;
            debug_io.put_line("post get imp #") ;
          IF ok THEN
            debug_io.put_line("pre get logical host #") ;
            get_logical_host_number(command_string(1..address_length),
             address_length, ok) ;
            debug_io.put_line("post get logical host#") ;
          IF ok THEN
            debug_io.put_line("pre get host #") ;
            get_host_number(command_string, address_length, ok) ;
            debug_io.put_line("post get host #") ;
          IF ok THEN
            debug_io.put_line("pre get network number") ;
            get_network_number(command_string, address_length, ok) ;
            debug_io.put_line("post get network number") ;
          END IF ; END IF ; END IF ; END IF ;
          IF NOT (ok) THEN
            type_of_command := bad_command ;
          END IF ;
          debug_io.put("port #=") ;
          debug_io.put_line(port_number) ;
          debug_io.put("imp #=") ;
          debug_io.put_line(imp_number) ;
          debug_io.put("logical host #=") ;
          debug_io.put_line(logical_host_number) ;
          debug_io.put("host #=") ;
          debug_io.put_line(host_number) ;
          debug_io.put("network #=") ;
          debug_io.put_line(network_number) ;
          debug_io.put_line("end process_open_command_parameters") ;
        EXCEPTION
          WHEN OTHERS =>
            debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.pr_open_cmd_par") ;
            RAISE ;
       END process_open_command_parameters ;


      BEGIN -- determine command type

        -- *debug* try assign in body part
        debug_io.put_line("in determine command type, will try to do assign") ;
        command_string(1..length) := command_string_in(1..length) ;
        debug_io.put_line("in determine command type, body assign complete") ;
        debug_io.put("command_string=") ;
        debug_io.put_line(command_string(1..length)) ;

        address_length := length ; -- pass in length of entire string
        debug_io.put_line("pre call of strip ex char") ;
        strip_off_extra_characters(command_string(1..length+3),
         address_length) ; -- pass in room for blank padding padding too(+3)
        debug_io.put_line("post call of strip ex char") ;
        IF    command_string(1..4) = "O   " THEN
          type_of_command := open_command ;
          debug_io.put_line("pre process_open_command_parameters ") ;
          process_open_command_parameters ;
          debug_io.put_line("post process_open_command_parameters ") ;
        ELSIF command_string(1..4) = "C   " OR command_string(1..4)="c   " THEN
          type_of_command := close_command ;
        ELSIF command_string(1..4) = "S   " OR command_string(1..4)="s   " THEN
          type_of_command := status_command ;
        ELSIF command_string(1..4) = "R   " OR command_string(1..4)="r   " THEN
          type_of_command := reset_command ;
        ELSIF command_string(1..4) = "EL  " OR command_string(1..4)="el  " THEN
          type_of_command := echo_local_command ;
        ELSIF command_string(1..4) = "ER  " OR command_string(1..4)="er  " THEN
          type_of_command := echo_remote_command ;
        ELSIF command_string(1..4) = "QEL " OR command_string(1..4)="qel " THEN
          type_of_command := quit_echo_local_command ;
        ELSIF command_string(1..4) = "QER " OR command_string(1..4)="qer " THEN
          type_of_command := quit_echo_remote_command ;
        ELSIF command_string(1..4) = "SGL " OR command_string(1..4)="sgl " THEN
          type_of_command := suppress_ga_local_command ;
        ELSIF command_string(1..4) = "SGR " OR command_string(1..4)="sgr " THEN
          type_of_command := suppress_ga_remote_command ;
        ELSIF command_string(1..4) = "QSGL" OR command_string(1..4)="qsgl" THEN
          type_of_command := quit_suppress_ga_local_command ;
        ELSIF command_string(1..4) = "QSGR" OR command_string(1..4)="qsgr" THEN
          type_of_command := quit_suppress_ga_remote_command ;
        ELSIF command_string(1..4) = "SAO " OR command_string(1..4)="sao " THEN
          type_of_command := send_abort_output_command ;
        ELSIF command_string(1..4) = "SAYT" OR command_string(1..4)="sayt" THEN
          type_of_command := send_are_you_there_command ;
        ELSIF command_string(1..4) = "SB  " OR command_string(1..4)="sb  " THEN
          type_of_command := send_break_command ;
        ELSIF command_string(1..4) = "SEC " OR command_string(1..4)="sec " THEN
          type_of_command := send_erase_character_command ;
        ELSIF command_string(1..4) = "SEL " OR command_string(1..4)="sel " THEN
          type_of_command := send_erase_line_command ;
        ELSIF command_string(1..4) = "SIP " OR command_string(1..4)="sip " THEN
          type_of_command := send_interrupt_process_command ;
        ELSIF command_string(1..4) = "SS  " OR command_string(1..4)="ss  " THEN
          type_of_command := send_sync_command ;
        ELSE
          type_of_command := bad_command ;
        END IF ;
        debug_io.put_line("end determine command type") ;
      EXCEPTION
        WHEN OTHERS =>
          debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.deter_cmd_type") ;
          RAISE ;
      END determine_command_type ;


      PROCEDURE convert_string_to_byte
                ----------------------
       (item  : IN  STRING ;
        bytes : OUT bytes_type) IS
      -- *********************  BODY SPECIFICATION  ***************************
      --
      -- This procedure converts a character string into an array of
      -- SYSTEM.BYTE suitable for sending to the NVT I/O package.
      -------------------------------------------------------------------------
      BEGIN
        FOR index IN 1..item'length LOOP
          bytes(bit_count_16_type(index)) := bit_count_8_type(CHARACTER'POS(item(index))) ;
        END LOOP ;
      END convert_string_to_byte ;


      PROCEDURE convert_user_data_bytes_to_string
                ---------------------------------
       (bytes  : IN     user_data.out_string_type ;
        str    :    OUT STRING ;
        length : IN     bit_count_16_type ;
        ok     :    OUT BOOLEAN) IS
      BEGIN
        ok := TRUE ;
        FOR index IN 1..length LOOP
          IF bytes(index) > 16#7F# THEN -- error
            ok := FALSE ;
            EXIT ; -- loop
          END IF ;

          str(bit_count_32_type(index)) := CHARACTER'VAL(bytes(index)) ;
--&MT     str(index) := CHARACTER'VAL(bytes(index)) ;

        END LOOP ;
      END convert_user_data_bytes_to_string ;


    BEGIN -- parse_for_semantics_and_make_call_to_presentation_level
-- move any enumerated type initializations to
-- body part(run time compiler bug)
      debug_io.put_line("begin parse for semantics and make call") ;
      user_data.get_command_buffer(command, length) ;
      convert_user_data_bytes_to_string
       (command, command_string, length, successful) ;
      IF successful THEN
        debug_io.put_line("keybd.parse_for_semantics") ;
        debug_io.put("command string=") ;

        debug_io.put_line(command_string(1..bit_count_32_type(length))) ;
--&MT   debug_io.put_line(command_string(1..length)) ;

        debug_io.put("command string length=") ;
        debug_io.put_line(length) ;

        determine_command_type(command_string, bit_count_32_type(length), type_of_command) ;
--&MT   determine_command_type(command_string, length, type_of_command) ;

      ELSE
        type_of_command := bad_command ;
      END IF ;

      CASE type_of_command IS
        -- transport level commands
        WHEN open_command =>
          debug_io.put_line("Making open command call to") ;
          debug_io.put_line
   ("virtual_transport_level.convert_service_call_to_transport_level_syntax") ;
          DECLARE
            parameter : virtual_transport_level.service_call_parameters_type
             (virtual_transport_level.TL_open) ;
          BEGIN
            parameter.network_number := network_number ;
            parameter.host_number := host_number ;
            parameter.logical_host_number := logical_host_number ;
            parameter.imp_number := imp_number ;
            parameter.port_number := port_number ;
            virtual_transport_level.convert_service_call_to_transport_level_syntax
             (virtual_transport_level.TL_open, parameter) ;
          END ; -- declare
        WHEN close_command =>
          debug_io.put_line("Making close command call to") ;
          debug_io.put_line
   ("virtual_transport_level.convert_service_call_to_transport_level_syntax") ;
          DECLARE
            parameter : virtual_transport_level.service_call_parameters_type
             (virtual_transport_level.TL_close) ;
          BEGIN
            virtual_transport_level.convert_service_call_to_transport_level_syntax
             (virtual_transport_level.TL_close, parameter) ;
          END ; -- declare
        WHEN status_command =>
          debug_io.put_line("Making status command call to") ;
          debug_io.put_line
   ("virtual_transport_level.convert_service_call_to_transport_level_syntax") ;
          DECLARE
            parameter : virtual_transport_level.service_call_parameters_type
             (virtual_transport_level.TL_status) ;
          BEGIN
            virtual_transport_level.convert_service_call_to_transport_level_syntax
             (virtual_transport_level.TL_status, parameter) ;
          END ; -- declare
        WHEN reset_command =>
          debug_io.put_line("Making reset command call to") ;
          debug_io.put_line
   ("virtual_transport_level.convert_service_call_to_transport_level_syntax") ;
          DECLARE
            parameter : virtual_transport_level.service_call_parameters_type
             (virtual_transport_level.TL_abort) ;
          BEGIN
            virtual_transport_level.convert_service_call_to_transport_level_syntax
             (virtual_transport_level.TL_abort, parameter) ;
          END ; -- declare

        -- TELNET commands
        WHEN echo_local_command =>
            option_negotiation.request_local_option_enable(user_data.echo) ;
        WHEN echo_remote_command =>
            option_negotiation.request_remote_option_enable(user_data.echo) ;
        WHEN quit_echo_local_command =>
            option_negotiation.demand_local_option_disable(user_data.echo) ;
        WHEN quit_echo_remote_command =>
            option_negotiation.demand_remote_option_disable(user_data.echo) ;
        WHEN suppress_ga_local_command =>
            option_negotiation.request_local_option_enable(user_data.suppress_ga) ;
        WHEN suppress_ga_remote_command =>
            option_negotiation.request_remote_option_enable(user_data.suppress_ga) ;
        WHEN quit_suppress_ga_local_command =>
            option_negotiation.demand_local_option_disable(user_data.suppress_ga) ;
        WHEN quit_suppress_ga_remote_command =>
            option_negotiation.demand_remote_option_disable(user_data.suppress_ga) ;
        WHEN send_abort_output_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 245 ;
          virtual_transport_level.send_data(command_bytes, not_urgent) ;
        WHEN send_are_you_there_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 246 ;
          virtual_transport_level.send_data(command_bytes, not_urgent) ;
        WHEN send_break_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 243 ;
          virtual_transport_level.send_data(command_bytes, not_urgent) ;
        WHEN send_erase_character_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 247 ;
          virtual_transport_level.send_data(command_bytes, not_urgent) ;
        WHEN send_erase_line_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 248 ;
          virtual_transport_level.send_data(command_bytes, not_urgent) ;
        WHEN send_interrupt_process_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 244 ;
          virtual_transport_level.send_data(command_bytes, not_urgent) ;
        WHEN send_sync_command =>
          command_bytes(1) := 255 ; -- page 14 of RFC 854
          command_bytes(2) := 242 ; -- data mark, must be accompanied by a TCP
                                    -- urgent notification
          virtual_transport_level.send_data(command_bytes, urgent) ;
        WHEN bad_command =>
          DECLARE -- aggregates would clean this up (not supported by Telelie)
            bad_message : STRING (1..6) ;
            bytes : bytes_type(1..6) ;
            not_control_characters : BOOLEAN := FALSE ;
          BEGIN
            bad_message(1..3) := "bad" ;
            bad_message(4) := ascii.bel ;
            bad_message(5) := ascii.cr ;
            bad_message(6) := ascii.lf ;
            convert_string_to_byte(bad_message, bytes) ;
            FOR index IN 1..6 LOOP
              virtual_terminal.output_character_to_nvt_printer
               (user_data.user_control_block.port, bytes(bit_count_16_type(index))) ;
            END LOOP ;
          END ; -- declare
      END CASE ;
      debug_io.put_line("end parse for semantics and make call") ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.parse_cmd") ;
        RAISE ;
    END parse_command_buffer_for_semantics_and_make_call_to_presentation_level ;


    FUNCTION char_not_end_of_line
             --------------------
     RETURN BOOLEAN IS
      end_of_line : character_type := 16#0D# ; -- ASCII.CR (arbitrary)
    BEGIN
      RETURN char /= end_of_line ;
    END char_not_end_of_line ;

    ------------------------  end subprogram declarations  -------------------

  BEGIN -- process partial command
    IF char_not_end_of_line THEN
      add_the_character_to_the_partial_command_buffer(char);
    ELSE
      parse_command_buffer_for_semantics_and_make_call_to_presentation_level ;

------------------------------------------------------------------------------
-- *** run-time compiler error: the initialization part of the declaration
--
--     does not happen at run time.  If the initialization is done explicitly
--     in the body part, the variable will be properly set.  Will just use
--     fully qualified name in body part.  TeleHosed again.
--
--      user_data.set_command_state_to(no_partial_command) ;
------------------------------------------------------------------------------

      user_data.user_control_block.command_state :=
       user_data.no_partial_command ;
    END IF ; -- end of line?
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.proc_par_cmd") ;
      RAISE ;
  END process_partial_command ;


  PROCEDURE put_character_in_data_buffer
            ----------------------------
   (char : IN character_type) IS
  BEGIN
    IF user_data.there_is_room_in_data_buffer THEN
      user_data.put_char_in_data_buffer(char) ;
    ELSE -- error
      NULL ; -- T B D (just "lose" it for now)
    END IF ;
  EXCEPTION
    WHEN OTHERS =>
       debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.put_char_dat_buf") ;
       RAISE ;
  END put_character_in_data_buffer ;


  PROCEDURE send_data_buffer_to_transport_level IS
            -----------------------------------

    apl_buffer : user_data.out_string_type ;
    ppl_buffer : virtual_transport_level.info_output_type
     (1..user_data.max_out_string) ;
    length : bit_count_16_type RANGE 1..user_data.max_out_string ;
    not_urgent_data : BOOLEAN := FALSE ;

  BEGIN
    user_data.user_control_block.ga_received := FALSE ;
    user_data.get_data_buffer(apl_buffer, length) ;
    FOR index IN 1..length LOOP -- convert to ppl type
      ppl_buffer(index) := apl_buffer(index) ;
    END LOOP ;
    virtual_transport_level.send_data
     (ppl_buffer(1..length), not_urgent_data) ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac.") ;
      RAISE ;
  END send_data_buffer_to_transport_level ;

BEGIN
  NULL ;
EXCEPTION
  WHEN OTHERS =>
    debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN akeybdpac instantition") ;
    RAISE ;
END nvt_keyboard_input_processing ; -- package body part
--::::::::::::::
--aplpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01047-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         APLPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : aplpac       AUTHOR : MIKE THOMAS

--   5/9/85  1:20 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

PACKAGE telnet_apl -- specification
        ----------
 IS
--************************  USER SPECIFICATION  ******************************
--
--                     TELNET APPLICATION PROTOCOL LEVEL SPECIFICATION
--
-- The Application Protocol Level (APL)... [1]
--
--   * defines the semantics for information exchange; [2]
--   * provides network transparency; [3]
--   * and partitions the problem into high level functional areas : [4]
--     : read/write characters from/to the Network Virtual Terminal (NVT)
--       via the Presentation Protocol Level (PPL),
--     : handle standard control functions (ip, ao, ayt, ec, and el),
--     : perform command parsing,
--     : pass the commands to the Presentation Protocol Level (PPL) for
--       submission to the transport level protocol,
--     : receive responses/messages from the transport level protocol via the
--       Presentation Protocol Level (PPL).
--
-- SPECIFICATION REFERENCES:
--
--      DOD Protocol Reference Model (contract DCA 100-82-C-0036  2-Dec-83)
--
--        [1] section 4.1.1
--        [2] section 4.1.1.1
--        [3] section 4.1.1.2
--        [4] section 4.1.1.3
--
-----------------------------------------------------------------------------

-- **************************************************************************
--
-- This package performs the TELNET application protocol level(APL) processing
-- and imports procedures to access the TELNET presentation protocol
-- level(PPL).  This package is responsible for the semantics of the user
-- information exchange and uses the virtual resources provided for by the PPL
-- to access the network virtual terminal(NVT) and virtual transport level.
-- For example, this level could access the NVT to get user/process input
-- to TELNET; determine that it was a proper TELNET command to open a new
-- connection and call upon the virtual transport level to establish the
-- new connection.  If the real world terminal type were to change or the
-- transport level's actual implementation were changed, this would have no
-- effect on the APL.
--
-- ****************************************************************************


  PROCEDURE process_any_input_from_the_nvt_keyboard ; -- specification
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will input and process one character from the NVT
  -- keyboard if one is available.
  -----------------------------------------------------------------------------


  PROCEDURE process_any_messages_from_the_transport_level ; -- specification
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will input and process one entire message from the
  -- transport level if a message is available.  A message being information
  -- for the local user/process which was generated by the local transport
  -- level, not simply data being relayed from the remote TELNET.
  -----------------------------------------------------------------------------


  PROCEDURE process_any_input_from_the_transport_level ; -- specification
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will input and process one character from the
  -- transport level which was relayed from the remote TELNET if it is
  -- available.
  -----------------------------------------------------------------------------


  PROCEDURE transmit_telnet_go_ahead ; -- specification
  -- ************************  USER SPECIFICATION  ****************************
  --
  -- This procedure will send the TELNET GA signal to the remote TELNET.
  -----------------------------------------------------------------------------

END telnet_apl ; -- package specification

--::::::::::::::
--aplpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01048-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         APLPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : aplpac       AUTHOR : MIKE THOMAS

--    5/9/85  1:25 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT
--   6/23/85  9:00 PM : set ga_state := no_ga_sent if there is input from tcp
--   6/24/85 10:19 AM : move set go_ahead to not control func part of if stm

WITH nvt_keyboard_input_processing ; -- procedures used in
USE  nvt_keyboard_input_processing ; -- process_any_input_from_the_nvt_keyboard

WITH message_processing ; -- procedures/data/types used in
USE  message_processing ; -- process_any_messages_from_the_transport_level

WITH transport_level_input_processing ; -- procedures used in
USE  transport_level_input_processing ; -- process_any_input_from_the_transport_level

WITH user_data ; -- state information, user buffers, and data types
USE  user_data ;

WITH virtual_terminal ; -- for local character echoing
WITH virtual_transport_level ; -- to send telnet go ahead, echo data to remote
WITH SYSTEM ; -- for access to system.byte
WITH debug_io ;

PACKAGE BODY telnet_apl IS
             ----------

--&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 ;

  PROCEDURE process_any_input_from_the_nvt_keyboard -- body
            ---------------------------------------
   IS
  -- *********************  BODY SPECIFICATION  *******************************
  --
  -- Processing sequence :
  --
  -- While there is input to process...
  -- If there is input from the NVT keyboard, get a character.   Set the
  -- NVT I/O state as I/O-done.  If the character was a standard control
  -- function, process the standard control function.  If the character was
  -- not a control function then process it as follows.  If the
  -- communication state is no-connection-established or the command state
  -- is partial-command or a new command was detected then set the NVT I/O
  -- state as partial-command and process a partial command.  Otherwise the
  -- input is data so put the character in the data buffer until an end of
  -- line is detected and then send it through to the transport level.
  ----------------------------  data declarations  ---------------------------

    char : bit_count_8_type ;
    end_of_line : CONSTANT bit_count_8_type := 16#0D# ; -- ASCII.CR
    TYPE control_function IS (ip, ao, ayt, ec, el) ;
    the_char_was_a_control_function : BOOLEAN ;
    standard_control_function : control_function ;
    at_char : CONSTANT bit_count_8_type := 16#40# ; -- ascii '@' (command character)
    last_char_was_an_at : BOOLEAN RENAMES
     user_control_block.last_keybd_char_was_cmd ;
  -------------------------  local procedure declarations  --------------------

    PROCEDURE check_for_local_printing (char : IN bit_count_8_type) IS
              ------------------------
      remote_options_in_effect : user_data.option_table_type
       RENAMES user_control_block.option_tables.remote_options_in_effect ;
      echo_local : BOOLEAN := TRUE ;
    BEGIN
      FOR index IN 1..remote_options_in_effect.number_of_items LOOP
        IF remote_options_in_effect.option(index) = user_data.echo THEN
          echo_local := FALSE ;
          EXIT ;
        END IF ;
      END LOOP ;
      IF echo_local THEN
        virtual_terminal.output_character_to_nvt_printer
         (user_data.user_control_block.port, char) ;
      END IF ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.check_loc_print") ;
        RAISE ;
    END check_for_local_printing ;


    FUNCTION time_to_transmit (char : IN bit_count_8_type) RETURN BOOLEAN IS
             ----------------
    -- *************************  SPECIFICATION  ******************************
    -- This function returns true if it is time to transmit the characters
    -- which were typed into the keyboard and are to be sent to the remote
    -- TELNET connection.  In the default NVT options, this would be at the
    -- end of a line.[1]  Other options in effect (such as remote ECHO) may
    -- be criteria for character-at-a-time as appossed to line-at-a-time
    -- transmissions.[2]
    --
    -- SPECIFICATION REFERENCES :
    --    [1] Network Working Group Request For Comments : 854, May 1983
    --        (page 5, default condition 1)
    --    [2] Network Working Group Request For Comments : 857, May 1983
    --        (page 3, paragraph 1)
    ---------------------------------------------------------------------------

      transmit_time : BOOLEAN := FALSE ;
      remote_options_in_effect : user_data.option_table_type
       RENAMES user_control_block.option_tables.remote_options_in_effect ;
      local_options_in_effect : user_data.option_table_type
       RENAMES user_control_block.option_tables.local_options_in_effect ;
      remote_options_pending : user_data.option_table_type
       RENAMES user_control_block.option_tables.remote_options_pending ;
      local_options_pending : user_data.option_table_type
       RENAMES user_control_block.option_tables.local_options_pending ;

      FUNCTION option_in_table
               ---------------
       (table  : IN user_data.option_table_type ;
        option : IN user_data.option_type) RETURN BOOLEAN IS
      BEGIN
        FOR index IN 1..table.number_of_items LOOP
          IF table.option(index) = option THEN
            RETURN TRUE ;
          END IF ;
        END LOOP ;
        RETURN FALSE ;
      END option_in_table ;

    BEGIN
      IF user_data.user_control_block.ga_received OR
       option_in_table(remote_options_in_effect, suppress_ga) THEN
        IF bit_count_16_type(char) = bit_count_16_type(end_of_line) AND THEN
         (remote_options_pending.number_of_items = 0 AND
         local_options_pending.number_of_items = 0) THEN
          transmit_time := TRUE ; -- end of line, no option negotiation pending
        ELSE -- not end of line
          IF option_in_table(remote_options_in_effect, suppress_ga) AND
           option_in_table(local_options_in_effect, suppress_ga) THEN
            IF option_in_table(remote_options_in_effect, echo) OR
             option_in_table(local_options_in_effect, echo) THEN
              transmit_time := TRUE ; -- suppress_ga & echo ==> character at a time mode
            END IF ; -- echo?
          END IF ; -- suppress_ga?
        END IF ; -- end of line?
      END IF ; -- ga_received?
      RETURN transmit_time ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.time_to_trans") ;
        RAISE ;
    END time_to_transmit ;


    PROCEDURE process_data_character(char : IN bit_count_8_type) IS
              ----------------------
    BEGIN
      debug_io.put_line("putting character in data buffer") ;
      put_character_in_data_buffer(char) ;
      IF bit_count_16_type(char) = bit_count_16_type(255) THEN -- double IAC on send to indecate a data byte 255
        put_character_in_data_buffer(char) ;
      END IF ;
      IF time_to_transmit(char) THEN
        debug_io.put_line("sending data buffer to trans level") ;
        send_data_buffer_to_transport_level ;
      END IF ; -- transmit buffer?
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_data_char") ;
        RAISE ;
    END process_data_character ;

  BEGIN -- process keyboard input
    debug_io.put_line("begin process keyboard input") ;
    IF there_is_input_from_the_NVT_keyboard THEN
      WHILE there_is_input_from_the_NVT_keyboard LOOP
        debug_io.put_line("apl process keyboard input thinks there is input") ;
        get_a_character(char, the_char_was_a_control_function);
        check_for_local_printing(char) ;
        user_control_block.NVT_IO_state := IO_done ;
        IF the_char_was_a_control_function THEN
          debug_io.put_line("will process control function...") ;
          process_standard_control_function_from_keyboard(char) ;
        ELSE -- not control function
          debug_io.put_line("character not a control function") ;
          IF user_control_block.communication_state =
           no_connection_established OR
           user_control_block.command_state = partial_command THEN
            debug_io.put_line("current character is part of partial command") ;
            user_control_block.command_state := partial_command ;
            process_partial_command(char) ;
          ELSE -- data
            debug_io.put_line("current character is data") ;
            IF last_char_was_an_at THEN
              IF bit_count_16_type(char) = bit_count_16_type(at_char) THEN -- put at #2 in data buf
                process_data_character(char) ;
                last_char_was_an_at := FALSE ;
              ELSE -- new command detected
                user_control_block.command_state := partial_command ;
                process_partial_command(at_char) ;
                process_partial_command(char) ;
                last_char_was_an_at := FALSE ;
              END IF ; -- char=at?
            ELSE -- last char /= at
              IF bit_count_16_type(char) = bit_count_16_type(at_char) THEN
                last_char_was_an_at := TRUE ;
              ELSE -- niether last char nor this char = at
                process_data_character(char) ;
              END IF ; -- transmit buffer?
            END IF ; -- last_char_was_an_at?
          END IF ; -- command?
        END IF ; -- control function?
      END LOOP ; -- input from keyboard?
    ELSE -- no input from keyboard, chack for send of buffered input
         -- due to pending option negotiation and/or go ahead processing
      IF user_data.there_is_data_in_data_buffer AND time_to_transmit(0) THEN
        send_data_buffer_to_transport_level ;
      END IF ; -- send buffered data?
    END IF ; -- keyboard input available?
    debug_io.put_line("end process keyboard input") ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_any_keybd_input") ;
      RAISE ;
  END process_any_input_from_the_NVT_keyboard ; -- procedure body


  PROCEDURE process_any_messages_from_the_transport_level -- body
            ---------------------------------------------
   IS
  --************************  BODY SPECIFICATION  *****************************
  --
  -- While there are messages to process...
  -- If there is a message from the transport level, retrieve the message and
  -- write the message to the NVT printer.  A message being information
  -- for the local user/process which was generated by the local transport
  -- level, not simply data being relayed from the remote TELNET.
  --------------------------  data declarations  ---------------------------

    message_from_transport_level : message_from_transport_level_type ;
    length                       : bit_count_16_type RANGE 1..max_msg_length ;

  BEGIN  -- process_any_messages_from_the_transport_level
    debug_io.put_line("begin telnet_apl.process_any_messages.") ;
    WHILE there_is_a_message_available LOOP
      retrieve_message(message_from_transport_level, length) ;
      debug_io.put("message length =") ;
      debug_io.put_line(length) ;
      write_message_to_NVT_printer(message_from_transport_level, length) ;
    END LOOP ; -- message to process?
    debug_io.put_line("end telnet_apl.process_any_messages.") ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_any_mess") ;
      RAISE ;
  END process_any_messages_from_the_transport_level ; -- body


  PROCEDURE process_any_input_from_the_transport_level -- body
            ------------------------------------------
   IS
  --**********************  BODY SPECIFICATION  ****************************
  --
  -- Processing sequence :
  --
  -- While there is input to process...
  -- If there is input from the transport level which is data simply
  -- relayed from the remote TELNET, input a character from the
  -- transport level and mark the NVT I/O state as having I/O-done.  If the
  -- character is not a standard control function, write it on the NVT
  -- printer.  If the character is a standard control function, process the
  -- standard control function.
  --------------------------  data declarations  -------------------------

    char : bit_count_8_type ;
    the_char_was_a_control_function : BOOLEAN ;
    urgent_data : BOOLEAN := TRUE ;
    echo_chars : virtual_transport_level.info_output_type
     (1..virtual_transport_level.max_msg_length) ;
    char_count : bit_count_16_type RANGE 0..virtual_transport_level.max_msg_length := 0 ;

    FUNCTION echo_to_remote RETURN BOOLEAN IS
             --------------
      local_options_in_effect : user_data.option_table_type RENAMES
       user_data.user_control_block.option_tables.local_options_in_effect ;
    BEGIN
      FOR index IN 1..local_options_in_effect.number_of_items LOOP
        IF local_options_in_effect.option(index) = user_data.echo THEN
          RETURN TRUE ;
        END IF ;
      END LOOP ;
      RETURN FALSE ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.ehco_to_remote") ;
        RAISE ;
    END echo_to_remote ;

  BEGIN -- process_any_input_from_transport_level
    debug_io.put_line
     ("begin telnet_apl.process_any_input_from_transport_level") ;
    WHILE there_is_input LOOP
      debug_io.put_line
      ("telnet_apl.process_any_input thinks there is input") ;
      input_character(char, the_char_was_a_control_function, urgent_data) ;
      debug_io.put("telnet_apl.proc_input.char=") ;
      debug_io.put_line_byte(char) ;

      IF the_char_was_a_control_function THEN
        debug_io.put_line("was a control function") ;
        process_standard_control_function(char, urgent_data) ;
      ELSE
        debug_io.put_line("was not a control function") ;
        user_data.user_control_block.ga_state := no_go_ahead_sent ;
        write_character_to_NVT_printer(char) ;
        user_control_block.NVT_IO_state := IO_done ;
        char_count := char_count + 1 ;
        echo_chars(char_count) := char ;
      END IF ; -- control function?
    END LOOP ; -- any input to process?
    IF echo_to_remote AND char_count > 0 THEN
      virtual_transport_level.send_data(echo_chars(1..char_count),urgent_data) ;
    END IF ;
    debug_io.put_line
     ("end telnet_apl.process_any_input_from_transport_level") ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac.proc_tl_input") ;
      RAISE ;
  END process_any_input_from_the_transport_level ; -- body


  PROCEDURE transmit_telnet_go_ahead -- body
            ------------------------
   IS
  --*************************  BODY SPECIFICATION  ***************************
  --
  -- Processing sequence ...
  --
  -- Send the TELNET GA (go ahead) signal through the presentation level
  -- to the transport level.
  --------------------------  data declarations  -----------------------------

    SUBTYPE telnet_go_ahead_type IS
     virtual_transport_level.info_output_type(1..2) ;
    telnet_go_ahead : telnet_go_ahead_type ;
    not_urgent      : BOOLEAN := FALSE ;

  BEGIN -- transmit_telnet_go_ahead
    debug_io.put_line("telnet go ahead sent") ;
    telnet_go_ahead(1) := 16#FF# ; -- RFC 854 page 14
    telnet_go_ahead(2) := 16#F9# ;
    IF virtual_transport_level.there_is_room_for_info_output THEN
      virtual_transport_level.send_data (telnet_go_ahead, not_urgent) ;
    END IF ;
  END transmit_telnet_go_ahead ; -- body

BEGIN -- telnet APL package body
  NULL ;
EXCEPTION
  WHEN OTHERS =>
    debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN aplpac instantiation") ;
    RAISE ;
END telnet_apl ; -- package

--::::::::::::::
--telnetpac_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01067-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         TELNETPAC_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

--   File : telnet         AUTHOR : MIKE THOMAS

--   5/9/85  2:20 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--*****************************************************************************
--                E-SYSTEMS, ECI DIVISION, ST. PETERSBURG, FL.
--
--
--  TITLE: Telnet
--
--  AUTHOR: Mike Thomas
--
--  LANGUAGE/COMPILER: TeleSoft ADA, version 1.5
--
--  CUSTOMER: Naval Ocean Systems Center
--
--  DEPENDENCIES
--     HARDWARE: VAX / WICAT
--     SOFTWARE: VMS version 3.6 / ROS version 2.1e - Labtek RTK 2.2
--
--  ABSTRACT: This is a source code listing of the Telnet communications
--            protocol Computer Program Package
--
--
--*****************************************************************************
--
--  REVISION         :  Number         -  1.0
--                      Date           -  12-OCT-84
--                      Author         -  Mike Thomas
--                      Change Summary -  Original Version
--
--                   :  Number         -  1.1
--                      Date           -  10-DEC-84
--                      Author         -  Mike Thomas
--                      Change Summary -  Ready for Test/Debug
--
--                   :  Number         -  2.0
--                      Date           -  29-JAN-84
--                      Author         -  Mike Thomas, Paul Higgins
--                      Change Summary -  run-time optimized version
--
--*****************************************************************************




--*****************************************************************************
--
--                          PACKAGE DESCRIPTIONS
--
--*****************************************************************************
--
-- Package Name : TELNET_PACKAGE                        File : telnetpac.txt
--
-- Abstract :
-- This package has the data types and data operations which are exported
-- to the TELNET controller program to allow the controller to set up the
-- data structure used by the TELNET procedure and the TELNET procedure
-- which services a TELNET user.
--
--
--
-- Package Name : TELNET_APL                            File : aplpac.txt
--
-- Abstract :
-- This package performs the high level processing associated with the
-- Telnet Aplication Level protocol.
--
--
--
-- Package Name : NVT_KEYBOARD_INPUT_PROCESSING         File : akeybdpac.txt
--
-- Abstract :
-- This package has subprograms to manage APL level processing of Network
-- Virtual keyboard input.
--
--
--
-- Package Name : TRANSPORT_LEVEL_INPUT_PROCESSING      File : atrinpac.txt
--
-- Abstract :
-- This package has APL subprograms used to process data input to the
-- local Telnet from the remote Telnet.
--
--
--
-- Package Name : MESSAGE PROCESSING                    File : amesspac.txt
--
-- Abstract :
-- This package has APL subprograms used to process message input to the
-- local Telnet from the local transport level.
--
--
--
--
-- Package Name : VIRTUAL_TERMINAL                      File : pvirtmpac.txt
--
-- Abstract :
-- This package provides low level Network Virtual Terminal services and
-- interfaces with the actual I/O device or process.
--
--
--
-- Package Name : VIRTUAL_TRANSPORT_LEVEL               File : pvirtlpac.txt
--
-- Abstract :
-- This package provides low level virtual transport level services and
-- interfaces with the actual transport level.
--
--
--
-- Package Name : USER_DATA                             File : auserdpac.txt
--
-- Abstract :
-- This package contains operations to examine and manipulate user APL
-- state information and APL buffers.
--
--
--
-- Package Name : OPTION_NEGOTIATION                    File : poptngpac.txt
--
-- Abstract :
-- This package contains subprograms to handle Telnet option negotiation.
--
-------------------------------------------------------------------------------



WITH user_data ;
USE  user_data ;
WITH option_negotiation ;

PACKAGE telnet_package -- specification
        --------------
 IS
-- **********************  USER SPECIFICATION  *****************************
--
-- This package has the data types and data operations which are exported
-- to the TELNET controller program to allow the controller to set up the
-- data structure used by the TELNET procedure and the TELNET procedure
-- which services a TELNET user.  An array of user data structures could be
-- used by the controller to serve multiple TELNET users.  The
-- user_information_type contains all the necessary information maintained
-- for a TELNET user.  The TELNET_options_supported_type lists the
-- non-default options currently supported by this implementation.  User
-- information directly alterable by the controller are the non-standard
-- TELNET options and I/O_device_characteristics.  The controller
-- can request to begin a non-default TELNET option, demand not to support a
-- non-default option, (as well as the same request/demand for the other
-- side of the TELNET connection) and set information regarding the actual
-- I/O device characteristics for a particular user.  These characteristics
-- should be initialized prior to running the TELNET procedure, but could
-- be dynamically changed if appropriate.
--
-- **************************************************************************

-- *debug*  make user_info_type public for test/debug *debug**********
--  TYPE user_info_type IS PRIVATE ; -- user specific information

--&MT SUBTYPE bit_count_16_type IS INTEGER ;
  SUBTYPE bit_count_16_type IS SHORT_INTEGER ;

  SUBTYPE user_info_type IS user_data.control_block_type ;

  SUBTYPE telnet_options_supported_type IS -- non-default options supported
   user_data.option_type ;
  TYPE io_device_supported_type IS (process, VT100) ;
  SUBTYPE io_port_address_type IS bit_count_16_type ; -- arbitrary

  PROCEDURE telnet_request_to_do_option -- specification
            ---------------------------
   (option :        IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) ;

    -- *********************  USER SPECIFICATION  *****************************
    --
    -- This procedure allows the TELNET controller to request a non-default
    -- TELNET option to be done locally.  Used primarily to initialize
    -- this information prior to using the TELNET procedure, but it
    -- can be used to dynamically request a change in TELNET options if
    -- desired.  If this procedure is used for a closed connection, TELNET
    -- will automatically try to negotiate that option upon the establishment
    -- of a new connection.
    ---------------------------------------------------------------------------


  PROCEDURE telnet_demand_not_to_do_option -- specification
            ------------------------------
   (option :        IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) ;

    -- *********************  USER SPECIFICATION  *****************************
    --
    -- This procedure allows the TELNET controller to demand a non-default
    -- TELNET option not be done locally.  Used primarily to initialize
    -- this information prior to using the TELNET procedure, but it
    -- can be used to dynamically request a change in TELNET options if
    -- desired.
    ---------------------------------------------------------------------------


  PROCEDURE telnet_request_remote_to_do_option -- specification
            ----------------------------------
   (option :        IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) ;

    -- *********************  USER SPECIFICATION  *****************************
    --
    -- This procedure allows the TELNET controller to request a non-default
    -- TELNET option to be done remotely.  Used primarily to initialize
    -- this information prior to using the TELNET procedure, but it
    -- can be used to dynamically request a change in TELNET options if
    -- desired.  If this procedure is used for a closed connection, TELNET
    -- will automatically try to negotiate that option upon the establishment
    -- of a new connection.
    ---------------------------------------------------------------------------


  PROCEDURE telnet_demand_remote_not_to_do_option -- specification
            -------------------------------------
   (option :        IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) ;

    -- *********************  USER SPECIFICATION  *****************************
    --
    -- This procedure allows the TELNET controller to demand a non-default
    -- TELNET option not be done remotely.  Used primarily to initialize
    -- this information prior to using the TELNET procedure, but it
    -- can be used to dynamically request a change in TELNET options if
    -- desired.
    ---------------------------------------------------------------------------


  PROCEDURE set_device_type -- specification
            ---------------
   (device_type :     IN IO_device_supported_type ;
    user_info :   IN OUT user_info_type) ;

    -- *********************  USER SPECIFICATION  *****************************
    --
    -- This procedure sets the device type for use by the TELNET
    -- presentation protocol level to allow actual communication
    -- with that process or device.  Used primarily to initialize
    -- this information prior to using the TELNET procedure, but it
    -- can be used to dynamically request a change if desired.
    ---------------------------------------------------------------------------


  PROCEDURE set_IO_port_address -- specification
            -------------------
   (IO_port_address :     IN IO_port_address_type ;
    user_info :       IN OUT user_info_type) ;

    -- *********************  USER SPECIFICATION  *****************************
    --
    -- This procedure sets the I/O port address for use by the TELNET
    -- presentation protocol level to allow actual communication
    -- with that process or device.  Used primarily to initialize
    -- this information prior to using the TELNET procedure, but it
    -- can be used to dynamically request a change if desired.
    ---------------------------------------------------------------------------

  -- Note : Other device specific procedures may have to be added here
  --        as deemed appropriate baised on the characteristics of the
  --        of the specific devices supported and the host system.



  PROCEDURE telnet -- specification
            ------
   (user_info : IN OUT user_info_type ;
    idle      :    OUT BOOLEAN) ;

    -- *****************  USER SPECIFICATION  *****************************
    --
    -- This procedure implements the TELNET [1] communication protocol
    -- for a single user.  One "pass" is made for all sources of I/O
    -- for a user for each call of this procedure.  The controlling
    -- program should initialize any non-default options desired and I/O
    -- device characteristics prior to calling telnet.  An array of
    -- user_info_type variables would allow the controller to process
    -- multiple users of TELNET.
    --
    -- SPECIFICATION REFERENCES:
    --
    --    [1] Network Working Group Request for Comments: 854, May 1983,
    --        TELNET PROTOCOL SPECIFICATION
    -----------------------------------------------------------------------

-- made public for test/debug
--  PRIVATE
--    TYPE user_info_type IS -- user specific information
--      RECORD
--        user_control_block : user_data.control_block_type ;
--      END RECORD ;

END telnet_package ; -- specification

--::::::::::::::
--telnetpac.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01068-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         TELNETPAC.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File telnetpac      AUTHOR : MIKE THOMAS

--   5/9/85  2:35 PM : MODIFY FOR DEC ADA
--                     OLD CODE (TELESOFT) MARKED AS --&MT
--  6/23/85  8:57 PM : don't set ga state at top of telnet proc
--   7/1/85  2:52 PM : remove status variable from option request

WITH telnet_apl ; -- TELNET application protocol level
USE telnet_apl ;
WITH debug_io ;

PACKAGE BODY telnet_package IS
             --------------

  PROCEDURE telnet_request_to_do_option -- body
            ---------------------------
   (option :        IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) IS

  BEGIN
--    user_data.put(user_info.user_control_block) ; -- store_user_information ;
    user_data.put(user_info) ; -- made public
    option_negotiation.request_local_option_enable(option) ;
--    user_data.get(user_info.user_control_block) ; -- restore_user_information ;
    user_data.get(user_info) ; -- made public
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.req_l_do_opt") ;
      RAISE ;
  END telnet_request_to_do_option ; -- body


  PROCEDURE telnet_demand_not_to_do_option -- body
            ------------------------------
   (option : IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) IS

  BEGIN
--    user_data.put(user_info.user_control_block) ; -- store_user_information ;
    user_data.put(user_info) ; -- made public
    option_negotiation.demand_local_option_disable(option) ;
--    user_data.get(user_info.user_control_block) ; -- restore_user_information ;
    user_data.get(user_info) ; -- made public
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.dem_l_n_do_opt") ;
      RAISE ;
  END telnet_demand_not_to_do_option ; -- body


  PROCEDURE telnet_request_remote_to_do_option -- body
            ----------------------------------
   (option :        IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) IS

  BEGIN
--    user_data.put(user_info.user_control_block) ; -- store_user_information ;
    user_data.put(user_info) ; -- made public
    option_negotiation.request_remote_option_enable(option) ;
--    user_data.get(user_info.user_control_block) ; -- restore_user_information ;
    user_data.get(user_info) ; -- made public
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.req_r_do_opt") ;
      RAISE ;
  END telnet_request_remote_to_do_option ; -- body


  PROCEDURE telnet_demand_remote_not_to_do_option -- body
            -------------------------------------
   (option : IN telnet_options_supported_type ;
    user_info : IN OUT user_info_type) IS

  BEGIN
--    user_data.put(user_info.user_control_block) ; -- store_user_information ;
    user_data.put(user_info) ; -- made public
    option_negotiation.demand_remote_option_disable(option) ;
--    user_data.get(user_info.user_control_block) ; -- restore_user_information ;
    user_data.get(user_info) ; -- made public
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.dem_r_n_d_opt") ;
      RAISE ;
  END telnet_demand_remote_not_to_do_option ;



  PROCEDURE set_device_type -- body
            ---------------
   (device_type : IN IO_device_supported_type ;
    user_info   : IN OUT user_info_type) IS --T B D

  BEGIN
    NULL ;
  END set_device_type ; -- body



  PROCEDURE set_IO_port_address -- body
            -------------------
   (IO_port_address : IN IO_port_address_type ;
    user_info : IN OUT user_info_type) IS -- T B D

  BEGIN
    user_info.port := io_port_address ;
  END set_IO_port_address ; -- body



  PROCEDURE telnet -- body
            ------
   (user_info : IN OUT user_info_type ;
    idle : OUT BOOLEAN) IS

    -- *****************  BODY SPECIFICATION  *****************************
    --
    -- Processing sequence...
    --
    -- Initialize the user information.  If the NVT I/O state is I/O done,
    -- then set the go ahead sent state to no_go_ahead_sent and the NVT I/O
    -- state to no I/O done.  Process any input from the NVT keyboard.  Process
    -- any messages from the transport level.  Process any transport level
    -- input.  If APL had completed sending data to the NVT printer  and  had
    -- no queued input from  the  NVT keyboard  for  further processing
    -- (NVT I/O  state  is no-I/O-done) and the TELNET go ahead was not
    -- already sent then the APL must transmit the TELNET GA (go ahead) to
    -- the transport level [2] and mark the go ahead sent state to
    -- go_ahead_sent.  Restore the user information.
    --
    --
    -- SPECIFICATION REFERENCES:
    --
    --    [1] Network Working Group Request for Comments: 854, May 1983,
    --        TELNET PROTOCOL SPECIFICATION
    --
    --    [2] RFC 854 : TELNET rotocol Specification
    --         page 5, condition 2
    --
    --------------------------------------------------------------------------

    old_communication_state : user_data.communication_state_type ;
    communication_state : user_data.communication_state_type RENAMES
     user_data.user_control_block.communication_state ;

    FUNCTION time_to_send_telnet_go_ahead RETURN BOOLEAN IS
             ----------------------------
      send_flag               : BOOLEAN := FALSE ;
      ga_not_suppressed       : BOOLEAN := TRUE ;
      local_options_in_effect : user_data.option_table_type RENAMES
       user_data.user_control_block.option_tables.local_options_in_effect ;
    BEGIN
      FOR index IN 1..local_options_in_effect.number_of_items LOOP
        IF local_options_in_effect.option(index) = suppress_ga THEN
          ga_not_suppressed := FALSE ;
          EXIT ;
        END IF ;
      END LOOP ;
      IF ga_not_suppressed AND THEN
       (user_control_block.NVT_IO_state = no_IO_done AND
       user_control_block.ga_state = no_go_ahead_sent AND
       user_control_block.communication_state =
       user_data.connection_established) THEN
         send_flag := TRUE ;
      END IF ;
      RETURN send_flag ;
    END time_to_send_telnet_go_ahead ;


  BEGIN

--    user_data.put(user_info.user_control_block) ; --initialize_user_information
    user_data.put(user_info) ; -- made public

    -- make one "pass" for this user
    old_communication_state := communication_state ;
    user_control_block.NVT_IO_state := no_IO_done ;
    process_any_input_from_the_nvt_keyboard ;
    process_any_messages_from_the_transport_level ;
    process_any_input_from_the_transport_level ;
    IF time_to_send_telnet_go_ahead THEN
      transmit_telnet_go_ahead ;
      user_control_block.ga_state := go_ahead_sent ;
    END IF ;
    IF (old_communication_state = user_data.no_connection_established) AND THEN
     (communication_state = user_data.connection_established) THEN
      option_negotiation.negotiate_initial_desired_options ;
    END IF ;

--    user_data.get(user_info.user_control_block) ; -- restore_user_information ;
    user_data.get(user_info) ; -- made public for ease of test/debug

  idle := user_control_block.nvt_io_state = no_io_done ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac.telnet") ;
      RAISE ;
  END telnet ; -- body

BEGIN -- telnet_package body
  NULL ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN telnetpac instantiation") ;
      RAISE ;
END telnet_package ; -- body
--::::::::::::::
--idebugso_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01057-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         IDEBUGSO_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : idebugso

--   5/9/85  2:53 PM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--   5/23/85  11:14 AM : MODIFY FOR TELESOFT    AUTHOR : MIKE THOMAS
--                       OLD CODE (DEC) MARKED AS --&MT

--   5/23/85  11:55 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                       OLD CODE (TELESOFT) MARKED AS --&MT

-- INTERACTIVE DEBUG STATE OUTPUT FOR TN TEST/DEBUG

WITH user_data ;
USE  user_data ;

PACKAGE I_debug_state_output IS

  PROCEDURE print_ppl_trans_buffers    (ucb : IN control_block_type) ;

  PROCEDURE print_telnet_option_tables (ucb : IN control_block_type) ;

  PROCEDURE print_user_control_block   (ucb : IN control_block_type) ;

  PROCEDURE dump_all                   (ucb : IN control_block_type) ;
  --    print_ppl_trans_buffers ;
  --    print_telnet_option_tables ;
  --    print_user_control_block ;
END I_debug_state_output ; -- spec

--::::::::::::::
--idebugso.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01058-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         IDEBUGSO.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : idebugso

--   5/9/85  3:00 PM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                     OLD CODE (TELESOFT) MARKED AS --&MT

--   5/23/85  11:14 AM : MODIFY FOR TELESOFT    AUTHOR : MIKE THOMAS
--                       OLD CODE (DEC) MARKED AS --&MT

--   5/23/85  11:59 AM : MODIFY FOR DEC ADA         AUTHOR : MIKE THOMAS
--                       OLD CODE (TELESOFT) MARKED AS --&MT

-- INTERACTIVE DEBUG STATE OUTPUT FOR TN TEST/DEBUG

WITH SYSTEM ; -- access ascii characters
WITH debug_io ; -- writes info to a debug file and/or the CRT.

PACKAGE BODY I_debug_state_output IS

  --&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 ;

  PROCEDURE print_ppl_trans_buffers (ucb : IN control_block_type) IS
  BEGIN
    debug_io.put_line(' ') ;
    debug_io.put_line("PPL TRANSPORT LEVEL BUFFERS.") ;
    debug_io.put_line("----------------------------") ;


    DECLARE
      in_buf     : trans_to_telnet_messages_record RENAMES
                   ucb.trans_buffers.trans_to_telnet_messages ;
      head       : trans_to_telnet_msg_buf_ptr_type := in_buf.buf_head ;
      tail       : trans_to_telnet_msg_buf_ptr_type := in_buf.buf_tail ;

      buf_length : CONSTANT bit_count_32_type :=
       bit_count_32_type(trans_to_telnet_msg_buffer_length) ;
--&MT buf_length : CONSTANT bit_count_16_type :=
--&MT  bit_count_16_type(trans_to_telnet_msg_buffer_length) ;

      out_buf    : STRING(1..buf_length) ;

      out_ptr    : bit_count_32_type RANGE 0..buf_length := 0 ;
--&MT out_ptr    : bit_count_16_type RANGE 0..buf_length := 0 ;

      char_byte  : bit_count_8_type ;
    BEGIN
      debug_io.put_line(' ') ;
      debug_io.put_line("TRANS TO TELNET MESSAGE BUFFER") ;
      debug_io.put("head=") ;
      debug_io.put(head) ;
      debug_io.put("  tail=") ;
      debug_io.put_line(tail) ;
      WHILE (head + 1) MOD bit_count_16_type(buf_length) /= tail LOOP
        head := (head + 1) MOD bit_count_16_type(buf_length) ;
        char_byte := in_buf.buffer(head) ;
        IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#)
         AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN
          out_ptr := out_ptr + 1 ;
          out_buf(out_ptr) := CHARACTER'VAL(char_byte) ;
        ELSE
          debug_io.put(out_buf(1..out_ptr)) ;
          out_ptr := 0 ;
          debug_io.put('<') ;
          debug_io.put_byte(char_byte) ;
          debug_io.put('>') ;
        END IF ;
      END LOOP ;
      debug_io.put_line(out_buf(1..out_ptr)) ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.TR TO TN MSG BUF") ;
        RAISE ;
    END ;

    DECLARE
      in_buf     : trans_to_telnet_data_record RENAMES
                   ucb.trans_buffers.trans_to_telnet_data ;
      head       : trans_to_telnet_data_buf_ptr_type := in_buf.buf_head ;
      tail       : trans_to_telnet_data_buf_ptr_type := in_buf.buf_tail ;

      buf_length : CONSTANT bit_count_32_type :=
       bit_count_32_type(trans_to_telnet_data_buffer_length) ;
--&MT buf_length : CONSTANT bit_count_16_type :=
--&MT  bit_count_16_type(trans_to_telnet_data_buffer_length)

      out_buf    : STRING(1..buf_length) ;

      out_ptr    : bit_count_32_type RANGE 0..buf_length := 0 ;
--&MT out_ptr    : bit_count_16_type RANGE 0..buf_length := 0 ;

      char_byte  : bit_count_8_type ;
    BEGIN
      debug_io.put_line(' ') ;
      debug_io.put_line("TRANS TO TELNET DATA BUFFER") ;
      debug_io.put("head=") ;
      debug_io.put(head) ;
      debug_io.put("  tail=") ;
      debug_io.put_line(tail) ;
      WHILE (head + 1) MOD bit_count_16_type(buf_length) /= tail LOOP
        head := (head + 1) MOD bit_count_16_type(buf_length) ;
        char_byte := in_buf.buffer(head) ;
        IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#)
         AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN -- printable
          out_ptr := out_ptr + 1 ;
          out_buf(out_ptr) := CHARACTER'VAL(char_byte) ;
        ELSE
          debug_io.put(out_buf(1..out_ptr)) ;
          out_ptr := 0 ;
          debug_io.put('<') ;
          debug_io.put_byte(char_byte) ;
          debug_io.put('>') ;
        END IF ;
      END LOOP ;
      debug_io.put_line(out_buf(1..out_ptr)) ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.TR TO TN DATA BUF") ;
        RAISE ;
    END ;

  END print_ppl_trans_buffers ;



  PROCEDURE print_telnet_option_tables (ucb : IN control_block_type) IS
    ot : option_tables_type
     RENAMES ucb.option_tables ;

    PROCEDURE print_items_in_table
              --------------------
     (table : IN user_data.option_table_type) IS
    BEGIN
      FOR index IN 1..table.number_of_items LOOP
        CASE table.option(index) IS
          WHEN user_data.echo =>
            debug_io.put(" echo ") ;
          WHEN user_data.suppress_ga =>
            debug_io.put(" suppress_ga ") ;
          WHEN OTHERS =>
            debug_io.put("undefined item") ;
        END CASE ;
      END LOOP ;
    END print_items_in_table ;

  BEGIN
    debug_io.put_line(' ') ;
    debug_io.put_line("TELNET OPTION TABLES") ;
    debug_io.put_line("--------------------") ;

    debug_io.put_line(' ') ;
    debug_io.put("local options desired : ") ;
    print_items_in_table(ot.local_options_desired) ;
    debug_io.put_line(' ') ;

    debug_io.put_line(' ') ;
    debug_io.put("remote options desired : ") ;
    print_items_in_table(ot.remote_options_desired) ;
    debug_io.put_line(' ') ;

    debug_io.put_line(' ') ;
    debug_io.put("local options pending : ") ;
    print_items_in_table(ot.local_options_pending) ;
    debug_io.put_line(' ') ;

    debug_io.put_line(' ') ;
    debug_io.put("remote options pending : ") ;
    print_items_in_table(ot.remote_options_pending) ;
    debug_io.put_line(' ') ;

    debug_io.put_line(' ') ;
    debug_io.put("local options in effect : ") ;
    print_items_in_table(ot.local_options_in_effect) ;
    debug_io.put_line(' ') ;

    debug_io.put_line(' ') ;
    debug_io.put("remote options in effect : ") ;
    print_items_in_table(ot.remote_options_in_effect) ;
    debug_io.put_line(' ') ;

  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.PRNT OPT TABS") ;
      RAISE ;

  END print_telnet_option_tables ;



  PROCEDURE print_user_control_block (ucb : IN control_block_type) IS
  BEGIN
    debug_io.put_line(' ') ;
    debug_io.put_line("USER CONTROL BLOCK.") ;
    debug_io.put_line("------------------") ;
    debug_io.put_line(' ') ;

    DECLARE -- partial command buffer
      length : CONSTANT partial_command_buf_length :=
       ucb.partial_command_buffer.length ;

      max_buf_length : CONSTANT bit_count_32_type :=
       bit_count_32_type(max_cmd_length) ;
--&MT max_buf_length : CONSTANT bit_count_16_type :=
--&MT  bit_count_16_type(max_cmd_length) ;

      out_buf : STRING(1..max_buf_length) ;

      out_ptr : bit_count_32_type RANGE 0..max_buf_length := 0 ;
--&MT out_ptr : bit_count_16_type RANGE 0..max_buf_length := 0 ;

      char_byte  : bit_count_8_type ;
    BEGIN
      debug_io.put_line("APL partial command buffer.") ;
      debug_io.put("length=") ;
      debug_io.put_line(length) ;
      FOR index IN 1..length LOOP
        char_byte := ucb.partial_command_buffer.buffer(index) ;
        IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#)
          AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN -- printable
          out_ptr := out_ptr + 1 ;
          out_buf(out_ptr) := CHARACTER'VAL(char_byte) ;
        ELSE -- print ascii code #
          debug_io.put(out_buf(1..out_ptr)) ;
          out_ptr := 0 ;
          debug_io.put('<') ;
          debug_io.put_byte(char_byte) ;
          debug_io.put('>') ;
        END IF ;
      END LOOP ;

--&MT   debug_io.put_line(out_buf(1..bit_count_16_type(length))) ;
        debug_io.put_line(out_buf(1..bit_count_32_type(length))) ;

    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.PART_CMD_BUF") ;
        RAISE ;
    END ;


    DECLARE -- data buffer
      head : data_buf_ptr := ucb.data_buffer.buf_head ;
      tail : data_buf_ptr := ucb.data_buffer.buf_tail ;

      buf_length : CONSTANT bit_count_32_type :=
       bit_count_32_type(data_buffer_length) ;
--&MT buf_length : CONSTANT bit_count_16_type :=
--&MT  bit_count_16_type(data_buffer_length) ;

      out_buf    : STRING(1..buf_length) ;

      out_ptr    : bit_count_32_type RANGE 0..buf_length := 0 ;
--&MT out_ptr    : bit_count_16_type RANGE 0..buf_length := 0 ;

      char_byte  : bit_count_8_type ;
    BEGIN
      debug_io.put_line(' ') ;
      debug_io.put_line("APL data buffer.") ;
      debug_io.put("head=") ;
      debug_io.put(head) ;
      debug_io.put("  tail=") ;
      debug_io.put_line(tail) ;
      WHILE (head + 1) MOD bit_count_16_type(buf_length) /= tail LOOP
        head := (head + 1) MOD bit_count_16_type(buf_length) ;
        char_byte := ucb.data_buffer.buffer(head) ;
        IF bit_count_16_type(char_byte) >= bit_count_16_type(16#20#)
         AND bit_count_16_type(char_byte) < bit_count_16_type(16#7F#) THEN -- printable
          out_ptr := out_ptr + 1 ;
          out_buf(out_ptr) := CHARACTER'VAL(char_byte) ;
        ELSE
          debug_io.put(out_buf(1..out_ptr)) ;
          out_ptr := 0 ;
          debug_io.put('<') ;
          debug_io.put_byte(char_byte) ;
          debug_io.put('>') ;
        END IF ;
      END LOOP ;
      debug_io.put_line(out_buf(1..out_ptr)) ;
    EXCEPTION
      WHEN OTHERS =>
        debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.DATA_BUF") ;
        RAISE ;
    END ;



  -- state information
    debug_io.put_line(' ') ;
    debug_io.put_line("STATE INFORMATION.") ;
    debug_io.put_line("------------------") ;
    debug_io.put_line(' ') ;

    debug_io.put("port=") ;
    debug_io.put_line(ucb.port) ;

    debug_io.put("tl_port_number=") ;
    debug_io.put_line(ucb.tl_port_number) ;

    debug_io.put("nvt_io_state = ") ;
    IF ucb.nvt_io_state = IO_done THEN
      debug_io.put_line("io_done") ;
    ELSIF ucb.nvt_io_state = no_IO_done THEN
      debug_io.put_line("no_io_done") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;

    debug_io.put("communication_state = ") ;
    IF ucb.communication_state = connection_established THEN
      debug_io.put_line("connection_established") ;
    ELSIF ucb.communication_state = no_connection_established THEN
      debug_io.put_line("no_connection_established") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;


    debug_io.put("command_state = ") ;
    IF ucb.command_state = partial_command THEN
      debug_io.put_line("partial_command") ;
    ELSIF ucb.command_state = no_partial_command THEN
      debug_io.put_line("no_partial_command") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;


    debug_io.put("ga_state = ") ;
    IF ucb.ga_state = go_ahead_sent THEN
      debug_io.put_line("go_ahead_sent") ;
    ELSIF ucb.ga_state = no_go_ahead_sent THEN
      debug_io.put_line("no_go_ahead_sent") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;

    debug_io.put("ga_received = ") ;
    IF ucb.ga_received = TRUE THEN
      debug_io.put_line("go_ahead_received") ;
    ELSIF ucb.ga_received = FALSE THEN
      debug_io.put_line("no_go_ahead_received") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;

    debug_io.put("synch_is_in_progress = ") ;
    IF ucb.synch_is_in_progress = TRUE THEN
      debug_io.put_line("synch_is_in_progress") ;
    ELSIF ucb.synch_is_in_progress = FALSE THEN
      debug_io.put_line("no_synch_is_in_progress") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;

    debug_io.put("last_keybd_char_was_cmd = ") ;
    IF ucb.last_keybd_char_was_cmd = TRUE THEN
      debug_io.put_line("TRUE") ;
    ELSIF ucb.synch_is_in_progress = FALSE THEN
      debug_io.put_line("FALSE") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;

    debug_io.put("rcv_data_is_urgent = ") ;
    IF ucb.rcv_data_is_urgent = TRUE THEN
      debug_io.put_line("TRUE") ;
    ELSIF ucb.rcv_data_is_urgent = FALSE THEN
      debug_io.put_line("FALSE") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;


    debug_io.put("last_data_char_rcv_not_cr = ") ;
    IF ucb.last_data_char_rcv_not_cr = TRUE THEN
      debug_io.put_line("TRUE") ;
    ELSIF ucb.last_data_char_rcv_not_cr = FALSE THEN
      debug_io.put_line("FALSE") ;
    ELSE
      debug_io.put_line("*UNDEFINED*") ;
    END IF ;


  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.PRINT UCB") ;
      RAISE ;

  END print_user_control_block ;



  PROCEDURE dump_all (ucb : IN control_block_type) IS
  BEGIN
    debug_io.put_line(' ') ;
    debug_io.put_line
     (".......................... dump all start ......................") ;
    debug_io.put_line(' ') ;

    print_ppl_trans_buffers(ucb) ;
    print_telnet_option_tables(ucb) ;
    print_user_control_block(ucb) ;

    debug_io.put_line(' ') ;
    debug_io.put_line
     ("eeeeeeeeeeeeeeeeeeeeeeeee  dump all end   eeeeeeeeeeeeeeeeeeeeee") ;
    debug_io.put_line(' ') ;
  EXCEPTION
    WHEN OTHERS =>
      debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.DUMP ALL") ;
      RAISE ;
  END dump_all ;

BEGIN
  NULL ;
EXCEPTION
  WHEN OTHERS =>
    debug_io.put_line("@#@#@#@ EXCEPTION RAISED IN IDEBUGSO.TR TO TN MSG BUF") ;
RAISE ;
END I_debug_state_output ;

--::::::::::::::
--server_telnet_package_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01157-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         SERVER_TELNET_PACKAGE_.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : server_telnet.ada     Author : Mike Thomas
-- interactive telnet controller/debugger
--
-- 5/31/85    4:21 PM : modify for dec
-- 6/10/85   10:40 AM : mods to run with new tcp on vax
--            1:28 PM : route debug to disk file
-- 6/11/85    5:42 PM : mod due to new tcp interface
-- 6/12/85    2:44 PM : ditto
-- 6/14/85    3:00 PM : tasking mod
-- 6/16/85    1:55 PM : input local port number for initial passive open
-- 6/17/85   10:24 AM : can't do above task steals it so hard code lpn
-- 6/18/85   11:36 AM : put initialization stuff in task
-- 6/19/85   10:39 AM : init tcp buffers
-- 6/20/85   11:20 AM : make server telnet
--            1:48 AM : kick off tcp_reader task
-- 6/24/85    2:05 PM : Make Procedure into a PACKAGE exporting task type
-- 7/10/85    2:52 PM : modify name of package
-- 7/11/85    9:53 AM : don't do passive open for user_ftp (port num=-1)

WITH buffer_data ; -- access sixteen_bits type, init buffers procedure
PACKAGE  server_telnet_package  IS                                      --&KJW
  USE buffer_data;                                                      --&KJW
                                                                        --&KJW
  TASK TYPE  telnet_controller  IS                                      --&KJW
    PRAGMA PRIORITY(7) ;                                                --&KJW
    ENTRY  Connection_Assignments ( local,foreign : sixteen_bits;       --&KJW
                                    foreign_net   : thirtytwo_bits );   --&KJW
  END telnet_controller ;                                               --&KJW
                                                                        --&KJW
END server_telnet_package ;
--&KJW
                                                                        --&KJW
--::::::::::::::
--server_telnet_package.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01066-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         SERVER_TELNET_PACKAGE.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : server_telnet.ada     Author : Mike Thomas
--                                     : Kevin Weise (convt to package)
-- interactive telnet controller/debugger
--
-- 5/31/85    4:21 PM : modify for dec
-- 6/10/85   10:40 AM : mods to run with new tcp on vax
--            1:28 PM : route debug to disk file
-- 6/11/85    5:42 PM : mod due to new tcp interface
-- 6/12/85    2:44 PM : ditto
-- 6/14/85    3:00 PM : tasking mod
-- 6/16/85    1:55 PM : input local port number for initial passive open
-- 6/17/85   10:24 AM : can't do above task steals it so hard code lpn
-- 6/18/85   11:36 AM : put initialization stuff in task
-- 6/19/85   10:39 AM : init tcp buffers
-- 6/20/85   11:20 AM : make server telnet
--            1:48 AM : kick off tcp_reader task
-- 6/24/85    2:05 PM : Make Procedure into a PACKAGE exporting task type
-- 7/10/85    2:52 PM : modify name of package
-- 7/11/85    9:53 AM : don't do passive open for user_ftp (port num=-1)
-- 7/12/85    1:21 PM : remove  : "with iotasks"
-- 7/14/85    9:00 PM : put option negotiation defaults in
-- 7/24/85    3:35 AM : disable debug output

WITH SYSTEM ; -- access ascii characters
WITH TEXT_IO ;
USE  TEXT_IO ;
WITH with_ulp_communicate ;

-- give i_controller access to all low level data structures
WITH debug_io ; -- writes info to a debug file and/or the CRT.
WITH i_debug_state_output ; -- state information output procedures
USE  i_debug_state_output ;
WITH user_data ;
USE  user_data ;

WITH telnet_package ;
WITH dec_tn_tasks ;

PACKAGE BODY  server_telnet_package IS          --&KJW
--&KJW  PROCEDURE server_telnet IS

  SUBTYPE bit_count_16_type is SHORT_INTEGER ;

  PACKAGE telnet_integer_io IS NEW
   text_io.integer_io(buffer_data.sixteen_bits) ;

-- This task is a mock controller/debugger for TELNET which will
-- simulate a TELNET user and TCP and call the TELNET procedure itself.
-- It will insert data and messages from the mock TCP into the
-- appropriate buffers so that TELNET will process them.  Likewise, it
-- will pull out messages and data that TELNET has sent to TCP and print
-- them.  Similer low level buffer processing will be done for the TELNET
-- user.

  TASK BODY telnet_controller IS --********** telnet_controller ****************
    idle            : BOOLEAN ; -- true when telnet did not process any input
    index           : bit_count_16_type := 0 ;
    user_dat_info   : telnet_package.user_info_type ;           --&KJW
    --  status : telnet_package.tp_status_type ;                --&KJW
    open_parameters : with_ulp_communicate.open_params ;        --&KJW
    options         : with_ulp_communicate.tcp_option_type ;    --&KJW
    tcp_message     : with_ulp_communicate.message ;            --&KJW
    lcn_pointer     : with_ulp_communicate.lcn_ptr_type ;       --&KJW
    request_ok      : BOOLEAN := FALSE ;                        --&KJW
    locl_prt,                                                   --&KJW
    forn_prt        : sixteen_bits;                             --&KJW
    forn_net        : thirtytwo_bits;                           --&KJW
  BEGIN
    --MT debug_io.destination := debug_io.debug_disk_file_only ;
    --MT debug_io.open_debug_disk_file ;
    debug_io.destination := debug_io.none ;

    buffer_data.init ; -- init tcp buffers

    telnet_package.set_io_port_address(1, user_dat_info) ;
  telnet_package.telnet_request_remote_to_do_option(suppress_ga, user_dat_info);
    telnet_package.telnet_request_to_do_option(suppress_ga, user_dat_info) ;
    -- telnet_package.telnet_request_to_do_option(echo, user_dat_info) ;


    debug_io.put_line("<<<<<<<  INITIAL STATE OF SERVER_TN  >>>>>>>>>") ;
    dump_all(user_dat_info) ; -- debug debugso

    ACCEPT Connection_Assignments ( local,foreign : sixteen_bits;       --&KJW
                                    foreign_net   : thirtytwo_bits ) DO --&KJW
        locl_prt := local;                                              --&KJW
        forn_prt := foreign;                                            --&KJW
        forn_net := foreign_net;                                        --&KJW
    END Connection_Assignments;                                         --&KJW

    IF locl_prt /= -1 THEN -- do passive open, set default option negotiation
      text_io.put_line("attempting passive open to tcp from controller...") ;
      debug_io.put_line("attempting passive open to tcp from controller...") ;
      FOR i IN 1..50 LOOP
        options(i) := 0 ;
      END LOOP ;
      open_parameters := (locl_prt,                     --&KJW
                          forn_prt,                     --&KJW
                          forn_net,                     --&KJW
                          with_ulp_communicate.passive,
                          0,
                          255,
                          lcn_pointer,
                          0,
                          0,
                          options) ;
      tcp_message := (with_ulp_communicate.open, open_parameters);
      with_ulp_communicate.message_for_tcp(tcp_message, request_ok) ;
      user_dat_info.lcn := tcp_message.open_parameters.local_connection_name ;
      IF request_ok THEN
        TEXT_IO.PUT_LINE("passive open REQUEST_OK") ;
        debug_io.put_line("passive open REQUEST_OK") ;
        debug_io.put_line("beginning calls to telnet") ;
        TEXT_IO.PUT_LINE ("beginning calls to telnet") ;
        dec_tn_tasks.tcp_reader.start ;
      ELSE
        TEXT_IO.PUT_LINE("passive open REQUEST_OK = FALSE!") ;
        debug_io.put_line("passive open REQUEST_OK = FALSE!") ;
      END IF ; --  request ok?
    END IF ; -- local port /= -1?
    LOOP -- CYCLE TELNET
      dec_tn_tasks.tn.wait ; -- wait for keyboard entry or message/data from TCP
      idle := FALSE ;
      WHILE NOT(idle) LOOP
        -- run telnet [one telnet pass]
        index := index + 1 ;
--        TEXT_IO.PUT_LINE("server telnet is running...") ;
--        TEXT_IO.NEW_LINE ;
        debug_io.put_line(" ") ;
        debug_io.put("********  *** *** ***  call #") ;
        debug_io.put(index) ;
        debug_io.put_line(" to telnet  *** *** *** *******") ;
        debug_io.put_line(" ") ;

        telnet_package.telnet(user_dat_info, idle) ;

        debug_io.put_line(" ") ;
        debug_io.put("^^^^^^^^ ^^^ ^^^ ^^^ after call #") ;
        debug_io.put(index) ;
        debug_io.put_line(" to server telnet  ^^^ ^^^ ^^^ ^^^^^^^^^") ;
        debug_io.put_line(" ") ;
        dump_all(user_dat_info) ;
      END LOOP ;
    END LOOP ;
    EXCEPTION
      WHEN OTHERS =>
        TEXT_IO.PUT_LINE("EXCEPTION IN TASK TELNET_CONTROLLER") ;
        DEBUG_IO.PUT_LINE("EXCEPTION IN TASK TELNET_CONTROLLER") ;
        RAISE ;
  END telnet_controller ;


BEGIN
  NULL ;
EXCEPTION
  WHEN OTHERS =>
  TEXT_IO.PUT_LINE("EXCEPTION IN PROCEDURE SERVER_TELNET") ;
  DEBUG_IO.PUT_LINE("EXCEPTION IN PROCEDURE SERVER_TELNET") ;
  RAISE ;

END server_telnet_package ;
--::::::::::::::
--server_telnet.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01065-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         SERVER_TELNET.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------
-- 7/11/85   9:51 AM :                File : server_telnet
--                                    AUTHOR : Mike Thomas
-- 7/12/85   1:23 PM : with iotasks

WITH iotasks ;
WITH server_telnet_package ;
USE  server_telnet_package ;
PROCEDURE server_telnet IS
  run_telnet_server_task : telnet_controller ;
BEGIN
  run_telnet_server_task.connection_assignments(2,0,0) ;
END server_telnet ;
--::::::::::::::
--user_telnet.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00004-200       80-01071-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         USER_TELNET.ADA       Author : Mike Thomas
--
-----------------------------------------------------------------------

-- File : user_telnet  Author : Mike Thomas
-- interactive telnet controler/debugger
--
-- 5/31/85    4:21 PM : modify for dec
-- 6/10/85   10:40 AM : mods to run with new tcp on vax
--            1:28 PM : route debug to disk file
-- 6/11/85    5:42 PM : mod due to new tcp interface
-- 6/12/85    2:44 PM : ditto
-- 6/14/85    3:00 PM : tasking mod
-- 6/16/85    1:55 PM : input local port number for initial passive open
-- 6/17/85   10:24 AM : can't do above task steals it so hard code lpn
-- 6/18/85   11:36 AM : put initialization stuff in task
-- 6/19/85   10:39 AM : init tcp buffers
--            8:41 PM : try turning debug off
-- 6/20/85   10:57 AM : make this a user telnet
--  7/2/85    1:06 PM : ask for remote echo, suppress ga's before run, debug off

WITH SYSTEM ; -- access ascii characters
WITH TEXT_IO ;
USE  TEXT_IO ;
WITH with_ulp_communicate ;
WITH buffer_data ; -- access sixteen_bits type, init buffers procedure

-- give i_controler access to all low level data structures
WITH debug_io ; -- writes info to a debug file and/or the CRT.
WITH i_debug_state_output ; -- state information output procedures
USE  i_debug_state_output ;
WITH user_data ;
USE  user_data ;

WITH telnet_package ;
WITH iotasks ;
WITH dec_tn_tasks ;

PROCEDURE user_telnet IS

-- This procedure is a mock controler/debugger for TELNET which will
-- simulate a TELNET user and TCP and call the TELNET procedure itself.
-- It will insert data and messages from the mock TCP into the
-- appropriate buffers so that TELNET will process them.  Likewise, it
-- will pull out messages and data that TELNET has sent to TCP and print
-- them.  Similer low level buffer processing will be done for the TELNET
-- user.

  idle : boolean ;
  user_dat_info : telnet_package.user_info_type ;
  SUBTYPE bit_count_16_type is SHORT_INTEGER ;

  PACKAGE telnet_integer_io IS NEW
   text_io.integer_io(buffer_data.sixteen_bits) ;

  open_parameters : with_ulp_communicate.open_params ;
  options : with_ulp_communicate.tcp_option_type ;
  tcp_message : with_ulp_communicate.message ;
  lcn_pointer : with_ulp_communicate.lcn_ptr_type ;
  request_ok : BOOLEAN := FALSE ;

  TASK telnet_controller IS
    PRAGMA PRIORITY(7) ;
  END telnet_controller ;

  TASK BODY telnet_controller IS --********** telnet_controler ****************
    idle : BOOLEAN ; -- true when telnet did not process any input
    index : bit_count_16_type := 0 ;
  BEGIN
    debug_io.destination := debug_io.debug_disk_file_only ;
    debug_io.open_debug_disk_file ;
    --MT debug_io.destination := debug_io.none ;

    buffer_data.init ; -- init tcp buffers

    telnet_package.set_io_port_address(1, user_dat_info) ;

--    telnet_package.telnet_request_remote_to_do_option(echo, user_dat_info) ;
--    telnet_package.telnet_request_remote_to_do_option(suppress_ga, user_dat_in
--    telnet_package.telnet_request_to_do_option(suppress_ga, user_dat_info) ;

    debug_io.put_line("<<<<<<<  INITIAL STATE OF USER_TN  >>>>>>>>>") ;
    dump_all(user_dat_info) ; -- debug debugso

    LOOP -- CYCLE TELNET
      dec_tn_tasks.tn.wait ; -- wait for keyboard entry or message/data from TCP
      idle := FALSE ;
      WHILE NOT(idle) LOOP
        -- run telnet [one telnet pass]
        index := index + 1 ;
--        TEXT_IO.PUT_LINE("user telnet is running...") ;
--        TEXT_IO.NEW_LINE ;
        debug_io.put_line(" ") ;
        debug_io.put("********  *** *** ***  call #") ;
        debug_io.put(index) ;
        debug_io.put_line(" to user telnet  *** *** *** *******") ;
        debug_io.put_line(" ") ;

        telnet_package.telnet(user_dat_info, idle) ;

        debug_io.put_line(" ") ;
        debug_io.put("^^^^^^^^ ^^^ ^^^ ^^^ after call #") ;
        debug_io.put(index) ;
        debug_io.put_line(" to user telnet  ^^^ ^^^ ^^^ ^^^^^^^^^") ;
        debug_io.put_line(" ") ;
        dump_all(user_dat_info) ;
      END LOOP ;
    END LOOP ;
    EXCEPTION
      WHEN OTHERS =>
        TEXT_IO.PUT_LINE("EXCEPTION IN TASK user TELNET_CONTROLLER") ;
        DEBUG_IO.PUT_LINE("EXCEPTION IN TASK user TELNET_CONTROLLER") ;
        RAISE ;
  END telnet_controller ;


BEGIN

---  debug_io.close_debug_disk_file ;
  dec_tn_tasks.tn.go ;
  EXCEPTION
    WHEN OTHERS =>
      TEXT_IO.PUT_LINE("EXCEPTION IN PROCEDURE USER_TELNET") ;
      DEBUG_IO.PUT_LINE("EXCEPTION IN PROCEDURE USER_TELNET") ;
      RAISE ;

END user_telnet ;