Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/TCPConnections.p

Text File | 1996-05-29 | 16.6 KB | 634 lines | [TEXT/CWIE]

unit TCPConnections;

{ TCPConnections © Peter Lewis, Oct 1991 }

interface

    uses
        TCPStuff;

    const
        tooManyConnections = -23099;

    const
        any_connection = 0;    { Pass to GetConnectionEvent }
        no_connection = -1;    { Guaranteed invalid connection }

    type
        connectionIndex = longint;
        connectionEvent = (C_NoEvent, C_Found, C_SearchFailed, C_NameFound, C_NameSearchFailed,{}
            C_Established, C_FailedToOpen, C_Closing, C_Closed, C_CharsAvailable, C_HeartBeat);
        connectionEventRecord = record
                event: connectionEvent;
                connection: connectionIndex;
                tcpc: TCPConnectionPtr;
                dataptr: Ptr;
                value: longint;
                timedout: boolean;
            end;

    function InitConnections: OSErr;
    procedure CloseConnections;
    procedure TerminateConnections;
    function CanQuit: boolean;
{ After Terminate, keep calling GetConnectionEvent(any_connection,cer) until CanQuit is true, then Finish }
    procedure FinishConnections;
    procedure FinishEverything;  { Or just call FinishEverything }
    function FindAddress (var cp: connectionIndex; hostName: Str255; dataptr: univ Ptr): OSErr;
    function FindName (var cp: connectionIndex; hostIP: longint; dataptr: univ Ptr): OSErr;
    procedure FindString (hostIP: longint; var s: Str255);
    function NewPassiveConnection (var cp: connectionIndex; buffersize: longint; localport: integer; remotehost: longint; remoteport: integer; dataptr: univ Ptr): OSErr;
    function NewActiveConnection (var cp: connectionIndex; buffersize: longint; localport: integer; remotehost: longint; remoteport: integer; dataptr: univ Ptr): OSErr;
    procedure CloseTCPConnection (cp: connectionIndex); { CloseConnection is defined in InterfaceLIB }
    procedure AbortConnection (cp: connectionIndex); { Violently close connection }
    function GetConnectionEvent (cp: connectionIndex; var cer: connectionEventRecord): boolean;
{ Pass any_connection for any event, otherwise cp specifies the event }
    procedure SetDataPtr (cp: connectionIndex; dataptr: univ Ptr);
    procedure GetDataPtr (cp: connectionIndex; var dataptr: univ Ptr);
    procedure SetConnectionTimeout (cp: connectionIndex; timeout: longint);
    procedure GetConnectionTimeout (cp: connectionIndex; var timeout: longint);
    procedure GetConnectionTCPC (cp: connectionIndex; var tcpc: TCPConnectionPtr);
    procedure SetHeartBeat (cp: connectionIndex; n: longint); { Send C_HeartBeat every n ticks, 0 disables Heartbeat }

implementation

    uses
        Textutils, DNR, Errors, MyMemory;

    const
        TCPCMagic = 'TCPC';
        TCPCBadMagic = 'badc';

    const  { Tuning parameters }
        max_connections = 40;
        TO_FindAddress = 40 * 60;
        TO_FindName = 40 * 60;
        TO_ActiveOpen = 20 * 60;
        TO_Closing = longint(2) * 60 * 60;
        TO_PassiveOpen = longint(1) * 365 * 24 * 3600 * 60;  { Ten years should be safe enough right? :-) }

    type
        myHostInfo = record
                hi: hostInfo;
                done: SignedByte;
            end;
        myHostInfoPtr = ^myHostInfo;
        statusType = (CS_None, CS_Searching, CS_NameSearching, CS_Opening, CS_Established, CS_Closing);
        connectionRecord = record
                magic: OSType;
                conmagic: longint;
                tcpc: TCPConnectionPtr;
                status: statusType;
                dnrrp: DNRRecordPtr;
                closedone: boolean;
                timeout: longint;
                dataptr: Ptr;
                Heartbeat: longint; { Time for next Heartbeat }
                period: longint; { Ticks per Heartbeat }
            end;

    var
        connections: array[1..max_connections] of connectionRecord;
        connectionItem: connectionIndex;
        connectionmagic: longint;

    function ValidConnectionSafe (var cp: connectionIndex): boolean;
        var
            ocp: longint;
            vc: boolean;
    begin
        vc := false;
        ocp := cp;
        cp := cp mod (max_connections + 1);
        if cp > 0 then begin
            if connections[cp].magic = TCPCMagic then begin
                if connections[cp].conmagic = ocp then begin
                    vc := true;
                end;
            end;
        end;
        ValidConnectionSafe := vc;
    end;

    function ValidConnection (var cp: connectionIndex): boolean;
        var
            vc: boolean;
    begin
        vc := ValidConnectionSafe(cp);
        if not vc then begin
            DebugStr('Invalid Connection');
        end;
        ValidConnection := vc;
    end;

    procedure SetDataPtr (cp: connectionIndex; dataptr: univ Ptr);
    begin
        if ValidConnection(cp) then begin
            connections[cp].dataptr := dataptr;
        end;
    end;

    procedure GetDataPtr (cp: connectionIndex; var dataptr: univ Ptr);
    begin
        if ValidConnectionSafe(cp) then begin
            dataptr := connections[cp].dataptr;
        end else begin
            dataptr := nil;
        end;
    end;

    procedure SetConnectionTimeout (cp: connectionIndex; timeout: longint);
    begin
        if ValidConnection(cp) then begin
            connections[cp].timeout := timeout;
        end;
    end;

    procedure GetConnectionTimeout (cp: connectionIndex; var timeout: longint);
    begin
        if ValidConnection(cp) then begin
            timeout := connections[cp].timeout;
        end else begin
            timeout := -1;
        end;
    end;

    procedure SetHeartBeat (cp: connectionIndex; n: longint); { Send C_HeartBeat every n ticks }
    begin
        if ValidConnection(cp) then begin
            if (n < 1) or (n = maxLongInt) then begin
                connections[cp].period := maxLongInt;
                connections[cp].Heartbeat := maxLongInt;
            end
            else begin
                connections[cp].period := n;
                connections[cp].Heartbeat := TickCount + n;
            end;
        end;
    end;

    procedure GetConnectionTCPC (cp: connectionIndex; var tcpc: TCPConnectionPtr);
    begin
        if ValidConnectionSafe(cp) then begin
            tcpc := connections[cp].tcpc;
        end else begin
            tcpc := nil;
        end;
    end;

    function MyTCPState (con: TCPConnectionPtr): TCPStateType;
    begin
        if con = nil then begin
            MyTCPState := T_Closed;
        end else begin
            MyTCPState := TCPState(con);
        end;
    end;

    function InitConnections: OSErr;
        var
            oe: OSErr;
            i: connectionIndex;
    begin
        for i := 1 to max_connections do begin
            connections[i].magic := TCPCBadMagic;
        end;
        connectionmagic := 0;
        connectionItem := 1;
        oe := TCPInit;
        if oe = noErr then begin
            oe := OpenResolver;
            if oe <> noErr then begin
                TCPFinish;
            end;
        end;
        InitConnections := oe;
    end;

    procedure TerminateConnections;
        var
            i: connectionIndex;
            oe: OSErr;
    begin
        for i := 1 to max_connections do begin
            with connections[i] do begin
                if magic = TCPCMagic then begin
                    if (status = CS_Established) or (status = CS_Opening) or (status = CS_Closing) then begin
                        if TCPState(tcpc) <> T_Closed then begin
                            oe := TCPAbort(tcpc);
                        end;
                    end;
                end;
            end;
        end;
    end;

    procedure CloseConnections;
        var
            i: connectionIndex;
            oe: OSErr;
    begin
        for i := 1 to max_connections do begin
            with connections[i] do begin
                if magic = TCPCMagic then begin
                    if (status = CS_Established) or (status = CS_Opening) or (status = CS_Closing) then begin
                        if TCPState(tcpc) <> T_Closed then begin
                            oe := TCPClose(tcpc, nil);
                        end;
                    end;
                end;
            end;
        end;
    end;

    function CanQuit: boolean;
        var
            i: connectionIndex;
    begin
        CanQuit := true;
        for i := 1 to max_connections do begin
            if connections[i].magic = TCPCMagic then begin
                CanQuit := false;
            end;
        end;
    end;

    procedure FinishConnections;
    begin
        CloseResolver;
        TCPFinish;
    end;

    procedure FinishEverything;
        var
            cer: connectionEventRecord;
            dummy: boolean;
            er: eventrecord;
    begin
        TerminateConnections;
        while not CanQuit do begin
            if GetConnectionEvent(any_connection, cer) then begin
                dummy := WaitNextEvent(everyEvent, er, 0, nil);
            end
            else
                dummy := WaitNextEvent(everyEvent, er, 5, nil);
        end;
        FinishConnections;
    end;

    function CreateConnection (var cp: connectionIndex; dp: Ptr): OSErr;
    begin
        connectionmagic := connectionmagic + max_connections + 1;
        cp := 1;
        while (connections[cp].magic = TCPCMagic) and (cp < max_connections) do begin
            cp := cp + 1;
        end;
        with connections[cp] do begin
            if magic = TCPCMagic then begin
                CreateConnection := tooManyConnections;
            end else begin
                magic := TCPCMagic;
                conmagic := cp + connectionmagic;
                closedone := false;
                tcpc := nil;
                status := CS_None;
                dnrrp := nil;
                timeout := maxlongInt;
                dataptr := dp;
                period := maxLongInt;
                Heartbeat := maxLongInt;
                CreateConnection := noErr;
                cp := cp + connectionmagic;

            end;
        end;
    end;

    procedure DestroyConnection (var cp: connectionIndex);
    begin
        if ValidConnection(cp) then begin
            connections[cp].magic := TCPCBadMagic;
        end;
        cp := -1;
    end;

    function FindAddress (var cp: connectionIndex; hostName: Str255; dataptr: univ Ptr): OSErr;
        var
            oe: OSErr;
            cpi: connectionIndex;
    begin
        oe := CreateConnection(cp, dataptr);
        if oe = noErr then begin
            cpi := cp;
            if ValidConnection(cpi) then begin
                with connections[cpi] do begin
                    oe := MNewPtr(dnrrp, SizeOf(DNRRecord));
                    if oe = noErr then begin
                        DNRNameToAddr(hostName, dnrrp, nil);
                        timeout := TickCount + TO_FindAddress;
                        status := CS_Searching;
                    end;
                end;
            end;
            if oe <> noErr then begin
                DestroyConnection(cp);
            end;
        end;
        FindAddress := oe;
    end;

    procedure FindString (hostIP: longint; var s: Str255);
    begin
        AddrToStr(hostIP, s);
    end;

    function FindName (var cp: connectionIndex; hostIP: longint; dataptr: univ Ptr): OSErr;
        var
            oe: OSErr;
            cpi: connectionIndex;
    begin
        oe := CreateConnection(cp, dataptr);
        if oe = noErr then begin
            cpi := cp;
            if ValidConnection(cpi) then begin
                with connections[cpi] do begin
                    oe := MNewPtr(dnrrp, SizeOf(DNRRecord));
                    if oe = noErr then begin
                        DNRAddrToName(hostIP, dnrrp, nil);
                        timeout := TickCount + TO_FindName;
                        status := CS_NameSearching;
                    end;
                end;
            end;
            if oe <> noErr then begin
                DestroyConnection(cp);
            end;
        end;
        FindName := oe;
    end;

    function NewPassiveConnection (var cp: connectionIndex; buffersize: longint; localport: integer; remotehost: longint; remoteport: integer; dataptr: univ Ptr): OSErr;
        var
            oe: OSErr;
            cpi: connectionIndex;
    begin
        oe := CreateConnection(cp, dataptr);
        if oe = noErr then begin
            cpi := cp;
            if ValidConnection(cpi) then begin
                with connections[cpi] do begin
                    oe := TCPPassiveOpen(tcpc, buffersize, localport, remotehost, remoteport, nil);
                    timeout := TickCount + TO_PassiveOpen;
                    status := CS_Opening;
                    if oe <> noErr then begin
                        DestroyConnection(cp);
                    end;
                end;
            end;
        end;
        NewPassiveConnection := oe;
    end;

    function NewActiveConnection (var cp: connectionIndex; buffersize: longint; localport: integer; remotehost: longint; remoteport: integer; dataptr: univ Ptr): OSErr;
        var
            oe: OSErr;
            cpi: connectionIndex;
    begin
        oe := CreateConnection(cp, dataptr);
        if oe = noErr then begin
            cpi := cp;
            if ValidConnection(cpi) then begin
                with connections[cpi] do begin
                    oe := TCPActiveOpen(tcpc, buffersize, localport, remotehost, remoteport, nil);
                    timeout := TickCount + TO_ActiveOpen;
                    status := CS_Opening;
                    if oe <> noErr then begin
                        DestroyConnection(cp);
                    end;
                end;
            end;
        end;
        NewActiveConnection := oe;
    end;

    procedure CloseTCPConnection (cp: connectionIndex);
        var
            err: OSErr;
    begin
        if ValidConnection(cp) then begin
            with connections[cp] do begin
                if not closedone then begin
                    if MyTCPState(tcpc) <> T_Closed then begin
                        err := TCPClose(tcpc, nil);
                    end;
                    closedone := true;
                end;
                status := CS_Closing;
                timeout := TickCount + TO_Closing;
            end;
        end;
    end;

    procedure AbortConnection (cp: connectionIndex);
        var
            err: OSErr;
    begin
        if ValidConnection(cp) then begin
            with connections[cp] do begin
                if MyTCPState(tcpc) <> T_Closed then begin
                    err := TCPAbort(tcpc);
                end;
                status := CS_Closing;
                timeout := TickCount + TO_Closing;
            end;
        end;
    end;

    function GetConnectionEvent (cp: connectionIndex; var cer: connectionEventRecord): boolean;
        procedure HandleConnection (cp: connectionIndex);
            var
                oe: OSErr;
                rcp: connectionIndex;
                tstate : TCPStateType;
        begin
            with connections[cp] do begin
                rcp := conmagic;
                cer.connection := rcp;
                cer.tcpc := tcpc;
                cer.dataptr := dataptr;
                cer.timedout := false;
                case status of
                    CS_NameSearching:
                        with dnrrp^ do begin
                            if ioResult <> inProgress then begin
                                if ioResult = noErr then begin
                                    cer.event := C_NameFound;
                                    StringHandle(cer.value) := NewString(name);
                                end
                                else begin
                                    cer.event := C_NameSearchFailed;
                                    cer.value := ioResult;
                                end
                            end
                            else if TickCount > timeout then begin
                                cer.event := C_NameSearchFailed;
                                cer.value := 1;
                                cer.timedout := true;
                            end;
                            if cer.event <> C_NoEvent then begin  { Destroy the connection now }
                                if ioResult <> inProgress then begin  { If we timed out, then we'll just have to abandon this block.  Oh well }
                                    MDisposePtr(dnrrp);
                                end;
                                dnrrp := nil;
                                DestroyConnection(rcp);
                            end; {if}
                        end; {with}
                    CS_Searching:
                        with dnrrp^ do begin
                            if ioResult = noErr then begin
                                cer.event := C_Found;
                                cer.value := addr;
                            end
                            else if ioResult <> inProgress then begin
                                cer.event := C_SearchFailed;
                                cer.value := ioResult;
                            end
                            else if TickCount > timeout then begin
                                cer.event := C_SearchFailed;
                                cer.value := 1;
                                cer.timedout := true;
                            end;
                            if cer.event <> C_NoEvent then begin  { Destroy the connection now }
                                if ioResult <> inProgress then begin  { If we timed out, then we'll just have to abandon this block.  Oh well }
                                    MDisposePtr(dnrrp);
                                end;
                                dnrrp := nil;
                                DestroyConnection(rcp);
                            end; {if}
                        end; {with}
                    CS_Opening:  begin
                        case MyTCPState(tcpc) of
                            T_WaitingForOpen, T_Opening, T_Listening:
                                if TickCount > timeout then begin
                                    CloseTCPConnection(rcp);
                                    cer.event := C_FailedToOpen;
                                    cer.timedout := true;
                                end;
                            T_Established:  begin
                                cer.event := C_Established;
                                status := CS_Established;
                                timeout := maxLongInt;
                            end;
                            T_PleaseClose, T_Closing:  begin
                                CloseTCPConnection(rcp);
                                cer.value := 1;
                                cer.event := C_FailedToOpen;
                                timeout := TickCount + TO_Closing;
                            end;
                            T_Closed:  begin
                                status := CS_Closing;
                                cer.value := 2;
                                cer.event := C_FailedToOpen;
                                timeout := TickCount + TO_Closing;
                            end;
                            otherwise
                                ;
                        end; {case }
                    end;
                    CS_Established:  begin
                        case MyTCPState(tcpc) of
                            T_Established:  begin
                                cer.value := TCPCharsAvailable(tcpc);
                                if cer.value > 0 then begin
                                    cer.event := C_CharsAvailable;
                                end;
                            end;
                            T_PleaseClose, T_Closing:  begin
                                cer.value := TCPCharsAvailable(tcpc);
                                if cer.value > 0 then begin
                                    cer.event := C_CharsAvailable;
                                end else begin
{    CloseTCPConnection(rcp);}
                                    status := CS_Closing;
                                    cer.event := C_Closing;
                                    timeout := TickCount + TO_Closing;
                                end;
                            end;

                            T_Closed:  begin
                                status := CS_Closing;
                                cer.event := C_Closing;
                                timeout := TickCount + TO_Closing;
                            end;
                            otherwise
                                ;
                        end;
                    end;
                    CS_Closing:  begin
                        tstate := MyTCPState(tcpc);
                        case tstate of
                            T_WaitingForOpen, T_Opening, T_Listening:
                                ;
{DebugStr('Strange State 2')}
                            T_PleaseClose, T_Closing, T_Established:  begin
                                cer.value := TCPCharsAvailable(tcpc);
                                if cer.value > 0 then begin
                                    cer.event := C_CharsAvailable;
                                end else if TickCount > timeout then begin
                                    cer.event := C_Closed;
                                    if tcpc <> nil then begin
{DebugStr('Closing timeout, call Abort;g');}
{oe := TCPAbort(tcpc);}
                                        oe := TCPRelease(tcpc);
                                    end;
                                    cer.timedout := true;
                                    DestroyConnection(rcp);
                                end;
                            end;
                            T_Closed:  begin
                                cer.event := C_Closed;
                                if tcpc <> nil then begin
                                    oe := TCPRelease(tcpc);
                                end;
                                DestroyConnection(rcp);
                            end;
                            otherwise
                                ;
                        end;
                    end;
                    otherwise
                        ;
                end;

                if (cer.event = C_NoEvent) & (TickCount > Heartbeat) then begin
                    cer.event := C_HeartBeat;
                    Heartbeat := TickCount + period;
                end;
            end;{with}
        end;{HandleConnection}
        var
            oci: connectionIndex;
    begin
        cer.event := C_NoEvent;
        if cp <> any_connection then begin
            if ValidConnection(cp) then begin
                HandleConnection(cp);
            end;
        end
        else begin
            oci := connectionItem;
            repeat
                if connections[connectionItem].magic = TCPCMagic then begin
                    HandleConnection(connectionItem);
                end;{if}
                if connectionItem = max_connections then begin
                    connectionItem := 1;
                end else begin
                    connectionItem := connectionItem + 1;
                end;
            until (oci = connectionItem) or (cer.event <> C_NoEvent);
        end;{if}
        GetConnectionEvent := cer.event <> C_NoEvent;
    end;{GetConnectionEvent}

end.