DataMuseum.dk

top - download

    Length: 6212 (0x1844)
    Types: TextFile
    Names: »B«

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─ ⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with System;
with Unchecked_Conversion;
with Mac_Types;
with Memory;
with Tcp;
package body Communications is


    Receive_Buffer_Size : constant := 16384;
    Read_Buffer_Size : constant := Receive_Buffer_Size + 4;
    Dtia_Port : constant Tcp.Tcp_Port := 2000;

    type Tcp_Driver_State is (Closed, Open);

    Tcp_State : Tcp_Driver_State := Closed;
    Receive_Buffer : Mac_Types.Ptr := null;


    function As_Ptr is new Unchecked_Conversion (Source => System.Address,
                                                 Target => Mac_Types.Ptr);

    use Mac_Types;
    procedure Initialize is
    begin
        if Tcp_State = Closed then
            Receive_Buffer := Memory.Newptr (Read_Buffer_Size);
            if Receive_Buffer = null then
                raise Memory_Full;
            end if;

            begin
                Tcp.Open_Tcp_Driver;
                Tcp_State := Open;
            exception
                when others =>
                    raise Open_Tcp_Driver_Failed;
            end;
        end if;
    end Initialize;


    use Mac_Types;
    procedure Wait_For_Connection (A_Connection : out Connection) is

        Recvptr : Mac_Types.Ptr;
        Recvlen : Mac_Types.Longint;
        Local_Connection : Connection;
    begin
        if Tcp_State /= Open then
            raise Open_Tcp_Driver_Failed;
        end if;

        Recvptr := Memory.Newptr (Receive_Buffer_Size);
        if Recvptr = null then
            raise Memory_Full;
        end if;

        begin
            Tcp.Low_Tcp_Create_Stream (Local_Connection.Stream, Recvptr,
                                       Receive_Buffer_Size, null, null);
        exception
            when others =>
                Memory.Disposptr (Recvptr);
                raise;
        end;

        Local_Connection.Stream_Created := True;
        Local_Connection.Connection_Opened := False;

        Local_Connection.Remote_Host := 0;
        Local_Connection.Remote_Port := 0;
        Local_Connection.Local_Host := 0;
        Local_Connection.Local_Port := Dtia_Port;

        Waiting_For_Connection:
            loop
                declare
                    Pb : Tcp.Tcpopenpbptr;
                begin
                    Tcp.Low_Tcp_Wait_For_Connection
                       (Local_Connection.Stream, 10,
                        Local_Connection.Remote_Host,
                        Local_Connection.Remote_Port,
                        Local_Connection.Local_Host,
                        Local_Connection.Local_Port, False, null, Pb);
                    Local_Connection.Connection_Opened := True;  
                    exit Waiting_For_Connection;
                exception  
                    when Tcp.Timeout_Error =>
                        null; -- Try again
                    when others =>
                        Local_Connection.Stream_Created := False;
                        Tcp.Low_Tcp_Release
                           (Local_Connection.Stream, Recvptr, Recvlen);
                        Memory.Disposptr (Recvptr);
                        raise;
                end;
            end loop Waiting_For_Connection;

        A_Connection := Local_Connection;
    end Wait_For_Connection;

    procedure Close_Connection (A_Connection : in out Connection) is

        Recvptr : Mac_Types.Ptr;
        Recvlen : Mac_Types.Longint;

    begin
        if Tcp_State /= Open then
            raise Open_Tcp_Driver_Failed;
        end if;

        if A_Connection.Connection_Opened then
            Tcp.Low_Tcp_Close (A_Connection.Stream, 2);
            Tcp.Low_Tcp_Abort (A_Connection.Stream);
            A_Connection.Connection_Opened := False;
        end if;
        if A_Connection.Stream_Created then
            Tcp.Low_Tcp_Release (A_Connection.Stream, Recvptr, Recvlen);
            Memory.Disposptr (Recvptr);
            A_Connection.Stream_Created := False;
        end if;
    end Close_Connection;

    procedure Write (A_Connection : in out Connection; Data : in Bytearray) is
        type Wds_Array is array (0 .. 1) of Tcp.Wdsentry;

        Mywds : Wds_Array;
        Pb : Tcp.Tcpsendpbptr;

    begin
        if Tcp_State /= Open then
            raise Open_Tcp_Driver_Failed;
        end if;

        if A_Connection.Stream_Created and A_Connection.Connection_Opened then
            Mywds (0).Length := Data'Length;
            Mywds (0).Ptr := As_Ptr (Data (Data'First)'Address);
            Mywds (1).Length := 0;
            Mywds (1).Ptr := null;
            Tcp.Low_Tcp_Send_Data
               (A_Connection.Stream, 10, True, False,
                As_Ptr (Mywds (Mywds'First)'Address), False, null, Pb);
        else
            raise Connection_Doesnt_Exist;
        end if;
    end Write;

    procedure Read (A_Connection : in out Connection; Data : out Bytearray) is
        Urgent : Boolean;
        Mark : Boolean;
        Remaining : Natural;
        Index : Natural;
        Rcvlen : Tcp.B_16;
        Pb : Tcp.Tcpreceivepbptr;

    begin
        if Tcp_State /= Open then
            raise Open_Tcp_Driver_Failed;
        end if;

        if A_Connection.Stream_Created and A_Connection.Connection_Opened then
            Remaining := Data'Length;
            Index := 0;
            while Remaining > 0 loop
                Rcvlen := Tcp.B_16 (Remaining);
                begin
                    Tcp.Low_Tcp_Recv_Data (A_Connection.Stream, 10,
                                           Urgent, Mark, Receive_Buffer,
                                           Rcvlen, False, null, Pb);
                    Memory.Blockmove
                       (Srcptr => Receive_Buffer,
                        Destptr => As_Ptr (Data (Data'First + Index)'Address),
                        Bytecount => Memory.Size (Rcvlen));
                    Index := Index + Natural (Rcvlen);
                    Remaining := Remaining - Natural (Rcvlen);  
                exception
                    when Tcp.Timeout_Error =>
                        null; -- try again
                    when others =>
                        raise;
                end;
            end loop;
        else
            raise Connection_Doesnt_Exist;
        end if;
    end Read;

end Communications;