Celestin Apprentice 4/Apprentice-Release4.iso/Source Code/Libraries/PNL Libraries/MyConnections.p

Text File | 1995-11-02 | 17.3 KB | 747 lines | [TEXT/CWIE]

unit MyConnections;

{ MyConnections © Peter N Lewis, 1993-95 }

interface

    uses
        TCPTypes, MyTypes, MyTransport;

    const
        tooManyConnections = -23099;
        timeoutError = -23098;
        failedToOpenError = -23097;

{ Sequence: }
{ new(obj) }
{ oe:=obj.Create }
{ if oe=noErr then begin }
{   do stuff}
{ end; }
{ obj.timetodie := true } { Don't call Destroy yourself }

    type
        ConnectionBaseObject = object
                timetodie: boolean; { Set this to have Destroy called at the end of HandleConnection }
                connection_index: integer; { private! }
                closedone: boolean;
                heartbeat_period: longInt; { set to <=0 to disable heartbeats }
                heartbeat_time: longInt; { set to time of next heartbeat, it is automatically incrememnted by the period }
{ To enable heartbeats, set heartbeat_time to TickCount, and heartbeat_period to the period in ticks }
                timeout_time: longInt; { set to time to timeout TickCount }
                dnr_token: ptr;
                function Create: OSErr;
                procedure Destroy;
                procedure HeartBeat;
                procedure Failed (oe: OSErr);
                procedure Close;
                procedure HandleConnection;
                procedure SetHeartBeat(period: longint);
            end;
        NameSearchObject = object(ConnectionBaseObject)
                ip: longInt;
                procedure HandleConnection;
                override;
                procedure FindName (hostIP: longInt);
                procedure FoundName (name: Str255; error: OSErr);
            end;
        AddressSearchObject = object(ConnectionBaseObject)
                object_host: Str255;
                procedure HandleConnection;
                override;
                procedure FindAddress (hostName: Str255);
                procedure FoundAddress (ip: longInt);
            end;
        UDPObject = object(ConnectionBaseObject)
                tref: TransportUDPRef;
                localport: integer;
                function Create: OSErr;
                override;
                function CreatePort (buffersize: longInt; port: integer): OSErr;
                procedure Close;
                override;
                procedure Destroy;
                override;
                procedure HandleConnection;
                override;
                procedure PacketAvailable (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer);
                procedure PacketsAvailable (count: integer);
                function SendPacket (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer; checksum: boolean): OSErr;
            end;
        statusType = (CS_Opening, CS_Established, CS_Closing);
        ConnectionObject = object(ConnectionBaseObject)
                tref: TransportRef;
                status: statusType;
                ourport: integer;
                input_buffer: Handle;
                output_buffer: Handle;
                transfer_error:OSStatus;
                do_send_close: Boolean;
                function Create: OSErr;
                override;
                procedure Destroy;
                override;
                procedure HandleConnection;
                override;
                procedure NewConnection (actve: boolean; buffersize: longInt; localport: integer; remotehost: Str255);
                procedure NewPassiveConnection (buffersize: longInt; localport: integer);
                procedure NewActiveConnection (buffersize: longInt; remotehost: Str255);
                procedure NewExistingConnection(newtref: TransportRef);
                procedure Close;
                override;
                procedure BeginConnection; { override these }
                procedure Established;
                procedure Closing;
                procedure CharsAvailable;
                procedure DoTransfer;
                procedure SendString (s: Str255);
                procedure SendData(datap: ptr; len: longint);
            end;
        LineConnectionObject = object(ConnectionObject)
                crlf: CRLFTypes;
                last_check: longInt; { last input_buffer size, dont recheck unless it changes }
                function Create: OSErr;
                override;
                procedure CharsAvailable;
                override;
                procedure SendLine (s: Str255);
                procedure LineAvailable (line: Str255);
                procedure CheckLineAvailable; { You can override this and use input_buffer yourself }
            end;

    procedure StartupConnections;
{ You probably wont need these: }
    function CanQuit: boolean;

implementation

    uses
        Devices, TextUtils,
        QLowLevel,
        DNR, MyStrings, MyMemory, MyMathUtils, MyStartup;

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

    const  { Tuning parameters }
        max_connections = 64;
        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;  { One years should be safe enough right? :-) }

    type
        myHostInfo = record
                hi: hostInfo;
                done: signedByte;
            end;
        myHIP = ^myHostInfo;

    var
        connections: array[1..max_connections] of ConnectionBaseObject;
        quiting: boolean;

    function CanQuit: boolean;
        var
            i: integer;
    begin
        CanQuit := true;
        for i := 1 to max_connections do begin
            if connections[i] <> nil then begin
                CanQuit := false;
                leave;
            end;
        end;
    end;

    function ConnectionBaseObject.Create: OSErr;
        var
            i: integer;
            err: OSStatus;
    begin
        MoveHHi(handle(self));
        HLock(handle(self));
        dnr_token := nil;
        err := noErr;
        if quiting then begin
            err := -12;
        end;
        if err = noErr then begin
            err := OpenTransportSystem;
        end;
        if err = noErr then begin
            i := 1;
            while (i <= max_connections) & (connections[i] <> nil) do begin
                i := i + 1;
            end;
            if i <= max_connections then begin
                timetodie := false;
                connection_index := i;
                connections[i] := self;
                heartbeat_period := -1;
                heartbeat_time := 0;
                timeout_time := maxLongInt;
                closedone := false;
            end else begin
                connection_index := -1;
                err := tooManyConnections;
            end;
        end;
        Create := err;
    end;

    procedure ConnectionBaseObject.Destroy;
    begin
        if connection_index > 0 then begin
            connections[connection_index] := nil;
        end;
        TransportAbortDNR(dnr_token);
        dispose(self);
    end;

    procedure ConnectionBaseObject.HeartBeat;
    begin
    end;

    procedure ConnectionBaseObject.Failed (err: OSErr);
    begin
        err := err; { UNUSED! }
        timetodie := true;
    end;

    procedure ConnectionBaseObject.Close;
    begin
        closedone := true;
    end;

    procedure ConnectionBaseObject.SetHeartBeat(period: longint);
        var
            time: longint;
    begin
        time := TickCount;
        if (heartbeat_period <= 0) or (period < 0) then begin
            heartbeat_time := time;
        end;
        heartbeat_period := period;
        if heartbeat_time < time then begin
            heartbeat_time := time;
        end;
        if (heartbeat_period > 0) & (heartbeat_time > time + heartbeat_period) then begin
            heartbeat_time := time + heartbeat_period;
        end;
    end;

    procedure ConnectionBaseObject.HandleConnection;
        var
            now: longInt;
    begin
        now := TickCount;
        if now > timeout_time then begin
            timeout_time := maxLongInt;
            Failed(timeoutError);
        end else if (heartbeat_period > 0) & (now >= heartbeat_time) then begin
            HeartBeat;
            heartbeat_time := heartbeat_time + heartbeat_period;
            if heartbeat_time < now then begin
                heartbeat_time := now;
            end;
        end;
    end;

    procedure AddressSearchObject.FindAddress (hostName: Str255);
        var
            err: OSErr;
    begin
        err := Create;
        if err = noErr then begin
            object_host := hostName;
            err := TransportNameToAddr(hostName, dnr_token);
            timeout_time := TickCount + TO_FindAddress;
        end;
        if err <> noErr then begin
            Failed(err);
            timetodie := true;
        end;
    end;

    procedure AddressSearchObject.FoundAddress (ip: longInt);
    begin
        ip := ip; { UNUSED! }
    end;

    procedure AddressSearchObject.HandleConnection;
        var
            result: OSStatus;
            addr:IPAddr;
    begin
        inherited HandleConnection;
        if not timetodie then begin
            TransportGetNameToAddrResult(dnr_token, result, nil, @addr, 1);
            if result = noErr then begin
                FoundAddress(addr);
                timetodie := true;
            end else if result <> inProgress then begin
                Failed(result);
                timetodie := true;
            end;
        end;
    end;

    procedure NameSearchObject.FindName (hostIP: longInt);
        var
            err: OSErr;
    begin
        ip := hostIP;
        err := Create;
        if err = noErr then begin
            err := TransportAddrToName(hostIP, dnr_token);
            timeout_time := TickCount + TO_FindName;
        end;
        if err <> noErr then begin
            Failed(err);
            timetodie := true;
        end;
    end;

    procedure NameSearchObject.FoundName (name: Str255; error: OSErr);
    begin
        name := name; { UNUSED! }
        error := error; { UNUSED! }
    end;

    procedure NameSearchObject.HandleConnection;
        var
            result: OSStatus;
            name:Str255;
    begin
        inherited HandleConnection;
        if not timetodie then begin
            TransportGetAddrToNameResult(dnr_token, result, name);
            if result <> inProgress then begin
                FoundName(name, result);
                timetodie := true;
            end;
        end;
    end;

    function UDPObject.Create: OSErr;
    begin
        tref := nil;
        localport := 0;
        Create := inherited Create;
    end;

    function UDPObject.CreatePort (buffersize: longInt; port: integer): OSErr;
        var
            err: OSErr;
    begin
        err := Create;
        if err = noErr then begin
            err := TransportUDPOpenPort(tref, port, buffersize);
            localport := port;
            timeout_time := maxLongInt;
        end;
        if err <> noErr then begin
            timetodie := true;
        end;
        CreatePort := err;
    end;

    procedure UDPObject.Close;
    begin
        timetodie := true;
        inherited Close;
    end;

    procedure UDPObject.Destroy;
    begin
        TransportUDPDestroy(tref);
        inherited Destroy;
    end;

    procedure UDPObject.PacketAvailable (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer);
    begin
        remoteIP := remoteIP; { UNUSED! }
        remoteport := remoteport; { UNUSED! }
        datap := datap; { UNUSED! }
        datalen := datalen; { UNUSED! }
    end;

    procedure UDPObject.PacketsAvailable (count: integer);
        var
            err: OSErr;
            remoteIP: longInt;
            remoteport: integer;
            datap: ptr;
            datalen: integer;
    begin
        count := count; { UNUSED! }
        err := TransportUDPRead (tref, remoteIP, remoteport, datap, datalen);
        if err = noErr then begin
            PacketAvailable(remoteIP, remoteport, datap, datalen);
            err := TransportUDPReturnBuffer(tref, datap);
        end;
    end;

    function UDPObject.SendPacket (remoteIP: longInt; remoteport: integer; datap: ptr; datalen: integer; checksum: boolean): OSErr;
    begin
        SendPacket := TransportUDPWrite (tref, remoteIP, remoteport, datap, datalen, checksum);
    end;

    procedure UDPObject.HandleConnection;
        var
            count: longInt;
    begin
        inherited HandleConnection;
        if not timetodie & (tref <> nil) then begin
            count := TransportUDPDatagramsAvailable(tref);
            if count > 0 then begin
                PacketsAvailable(count);
            end;
        end;
    end;

    procedure ConnectionObject.Established;
    begin
    end;

    procedure ConnectionObject.Closing;
    begin
        Close;
    end;

    procedure ConnectionObject.CharsAvailable;
    begin
    end;

    function ConnectionObject.Create: OSErr;
        var
            err, err2:OSErr;
    begin
        err := inherited Create;
        transfer_error := noErr;
        do_send_close := false;
        err2 := MNewHandle(input_buffer, 0);
        if err = noErr then begin
            err := err2;
        end;
        err2 := MNewHandle(output_buffer, 0);
        if err = noErr then begin
            err := err2;
        end;
        Create := err;
    end;

    procedure ConnectionObject.Destroy;
    begin
        TransportDestroy(tref);
        MDisposeHandle(input_buffer);
        MDisposeHandle(output_buffer);
        inherited Destroy;
    end;

    procedure ConnectionObject.SendData(datap: ptr; len: longint);
        var
            err: OSErr;
    begin
        err := PtrAndHand(datap, output_buffer, len);
        if transfer_error = noErr then begin
            transfer_error := err;
        end;
    end;

    procedure ConnectionObject.SendString (s: Str255);
    begin
        SendData(@s[1], length(s));
    end;

    procedure ConnectionObject.DoTransfer;
        procedure SetErr(err:OSStatus);
        begin
            if (transfer_error = noErr) then begin
                transfer_error := err;
            end;
        end;
        var
            err: OSStatus;
            count, len:longint;
    begin
        len := GetHandleSize(input_buffer);
        count := Min(TransportCharsAvailable(tref), 10240-len);
        if count > 0 then begin
            err := MSetHandleSize(input_buffer, len + count);
            if err = noErr then begin
                HLock(input_buffer);
                err := TransportReceive(tref, AddPtrLong(input_buffer^, len), count, count);
                HUnlock(input_buffer);
                SetErr(err);
                SetHandleSize(input_buffer, len + count);
            end;
        end;

        len := GetHandleSize(output_buffer);
        if len > 0 then begin
            HLock(output_buffer);
            err := TransportSend(tref, output_buffer^, len);
            HUnlock(output_buffer);
            SetHandleSize(output_buffer, 0);
            SetErr(err);
        end else if do_send_close then begin
            do_send_close := false;
            TransportSendClose(tref);
        end;
    end;

    procedure ConnectionObject.BeginConnection;
    begin
    end;

    procedure ConnectionObject.NewExistingConnection(newtref: TransportRef);
        var
            err: OSStatus;
    begin
        tref := newtref;
        err := Create;
        if err = noErr then begin
            err := TransportHandleTransfers(tref);
        end;
        if err = noErr then begin
            status := CS_Established;
            ourport := 0;
            timeout_time := maxLongInt;
            BeginConnection;
            Established;
        end else begin
            Failed(err);
        end;
    end;

    procedure ConnectionObject.NewConnection (active: boolean; buffersize: longInt; localport: integer; remotehost: Str255);
        var
            err: OSErr;
    begin
        tref := nil;
        err := Create;
        if err = noErr then begin
            status := CS_Opening;
            ourport := localport;
            if active then begin
                err := TransportOpenActiveConnection(tref, remotehost, ourport, buffersize);
                timeout_time := TickCount + TO_ActiveOpen;
            end else begin
                err := TransportOpenPassiveConnection(tref, ourport, buffersize);
                timeout_time := TickCount + TO_PassiveOpen;
            end;
        end;
        if err = noErr then begin
            err := TransportHandleTransfers(tref);
        end;
        if err = noErr then begin
            BeginConnection;
        end
        else begin
            Failed(err);
            timetodie := true;
        end;
    end;

    procedure ConnectionObject.NewPassiveConnection (buffersize: longInt; localport: integer);
    begin
        NewConnection(false, buffersize, localport, '');
    end;

    procedure ConnectionObject.NewActiveConnection (buffersize: longInt; remotehost: Str255);
    begin
        NewConnection(true, buffersize, 0, remotehost);
    end;

    procedure ConnectionObject.Close;
    begin
        if not closedone and (tref <> nil) then begin
            if GetHandleSize(output_buffer) > 0 then begin
                do_send_close := true;
            end else begin
                TransportSendClose(tref);
            end;
            closedone := true;
        end;
    end;

    procedure ConnectionObject.HandleConnection;
        var
            state: TCPStateType;
            result: OSStatus;
    begin
        inherited HandleConnection;
        if not timetodie then begin
            case status of
                CS_Opening:  begin
                    TransportGetOpenResult(tref, result);
                    if result = noErr then begin
                        Established;
                        status := CS_Established;
                        timeout_time := maxLongInt;
                    end else if result <> inProgress then begin
                        Failed(result);
                        timetodie := true;
                    end;
                end;
                CS_Established:  begin
                    DoTransfer;
                    state := TransportGetConnectionState(tref);
                    case state of
                        T_Established:  begin
                            if GetHandleSize(input_buffer) > 0 then begin
                                CharsAvailable;
                            end;
                        end;
                        T_PleaseClose, T_Closing:  begin
                            if GetHandleSize(input_buffer) > 0 then begin
                                CharsAvailable;
                            end else begin
                                Closing;
                                status := CS_Closing;
                                timeout_time := TickCount + TO_Closing;
                            end;
                        end;
                        T_Dead, T_Bored:  begin
                            Closing;
                            status := CS_Closing;
                            timeout_time := TickCount + TO_Closing;
                        end;
                        otherwise
                            ;
                    end;
                end;
                CS_Closing:  begin
                    DoTransfer;
                    state := TransportGetConnectionState(tref);
                    case state of
                        T_PleaseClose, T_Closing, T_Established:  begin
                            if GetHandleSize(input_buffer) > 0 then begin
                                CharsAvailable;
                            end;
                        end;
                        T_Dead, T_Bored:  begin
                            timetodie := true;
                        end;
                        otherwise
                            ;
                    end;
                end;
                otherwise
                    ;
            end;
        end;
    end;

    function LineConnectionObject.Create: OSErr;
    begin
        crlf := CL_CRLF;
        last_check := -1;
        Create := inherited Create;
    end;

    procedure LineConnectionObject.SendLine (s: Str255);
    begin
        if crlf <> CL_LF then begin
            s := concat(s, cr);
        end;
        if crlf <> CL_CR then begin
            s := concat(s, lf);
        end;
        SendData(@s[1], length(s));
    end;

    procedure LineConnectionObject.LineAvailable (line: Str255);
    begin
        line := line; { UNUSED! }
    end;

    procedure LineConnectionObject.CharsAvailable;
    begin
        CheckLineAvailable;
    end;

    procedure LineConnectionObject.CheckLineAvailable;
        var
            len, inbuf, junk_long: longInt;
            p: ptr;
            s: Str255;
    begin
        while true do begin
            inbuf := GetHandleSize(input_buffer);
            if (inbuf = 0) | (inbuf = last_check) then begin
                leave;
            end;
            p := input_buffer^;
            len := 0;
            while (len < inbuf) & (len < 255) & (p^ <> ord(lf)) & (p^ <> ord(cr)) do begin
                p := ptr(ord(p) + 1);
                len := len + 1;
            end;
            if (len = 255) | ((len < inbuf) & ((p^ = ord(lf)) | (p^ = ord(cr)))) then begin
{$PUSH}
{$R-}
                s[0] := chr(len);
                BlockMoveData(input_buffer^, @s[1], len);
{$POP}
                if (len < inbuf) & (p^ = ord(cr)) then begin
                    p := ptr(ord(p) + 1);
                    len := len + 1;
                end;
                if (len < inbuf) & (p^ = ord(lf)) then begin
                    p := ptr(ord(p) + 1);
                    len := len + 1;
                end;
                junk_long := Munger(input_buffer, 0, nil, len, @len, 0);
                LineAvailable(s);
                last_check := -1;
            end else begin
                last_check := inbuf;
            end;
        end;
    end;

    procedure IdleConnections;
        var
            i: integer;
    begin
        for i := 1 to max_connections do begin
            if connections[i] <> nil then begin
                if not connections[i].timetodie then begin
                    connections[i].HandleConnection;
                end;
                if connections[i].timetodie then begin
                    connections[i].Destroy;
                end;
            end;
        end;
    end;

    procedure FinishConnections;
        var
            i: integer;
    begin
        for i := 1 to max_connections do begin
            if connections[i] <> nil then begin
                connections[i].Destroy;
            end;
        end;
    end;

    procedure StartupConnections;
        var
            i: integer;
    begin
        quiting := false;
        for i := 1 to max_connections do begin
            connections[i] := nil;
        end;
        StartupTransport;
        SetStartup(nil, IdleConnections, 0, FinishConnections);
    end;

end.