Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/TCPExample/PNL Libraries/MyConnections.p

Text File | 1997-06-23 | 20.9 KB | 889 lines | [TEXT/CWIE]

unit MyConnections;

{ MyConnections © Peter N Lewis, 1993-96 }

interface

    uses
        Types, TCPTypes, MyTypes, OpenTransport, MyTransport, MyAssertions;

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

{ 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;
                hack_do_test_bad_connections: boolean;
                hack_test_bad_connections: boolean;
                function Create: OSStatus;
                procedure Destroy;
                procedure Heartbeat;
                procedure Failed (oe: OSStatus);
                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: OSStatus);
            end;
        AddressSearchObject = object(ConnectionBaseObject)
                object_host: Str255;
                addresses: array[1..k_max_found_addresses] of ipAddr;
                procedure HandleConnection;
                override;
                procedure FindAddress (hostName: Str255);
                procedure FoundAddress (ip: longint);
            end;
        ListenerObject = object(ConnectionBaseObject)
                listener: Ptr;
                localport: ipPort;
                function Create: OSStatus;
                override;
                procedure Destroy;
                override;
                function CreateListener(buffersize:longint; port:ipPort; listeners:integer): OSStatus;
                procedure HandleConnection;
                override;
                procedure ConnectionAvailable( connection: TransportRef ); { override this - do not call it! }
            end;
        UDPObject = object(ConnectionBaseObject)
                tref: TransportUDPRef;
                localport: ipPort;
                function Create: OSStatus;
                override;
                function CreatePort (buffersize: longint; port: ipPort): OSStatus;
                procedure Close;
                override;
                procedure Destroy;
                override;
                procedure HandleConnection;
                override;
                procedure PacketAvailable (remoteip: ipAddr; remoteport: ipPort; datap: Ptr; datalen: integer);
                procedure PacketsAvailable (count: integer);
                function SendPacket (remoteip: longint; remoteport: ipPort; datap: Ptr; datalen: integer; checksum: boolean): OSStatus;
            end;
        statusType = (CS_None, CS_Opening, CS_Established, CS_Closing);
        ConnectionObject = object(ConnectionBaseObject)
                tref: TransportRef;
                status: statusType;
                ourport: ipPort;
                input_buffer: Handle;
                output_buffer: Handle;
                transfer_error:OSStatus;
                do_send_close: Boolean;
                function Create: OSStatus;
                override;
                procedure Destroy;
                override;
                procedure HandleConnection;
                override;
                procedure NewConnection (actve: boolean; buffersize: longint; localport: ipPort; remotehost: Str255);
                procedure NewPassiveConnection (buffersize: longint; localport: ipPort);
                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: OSStatus;
                override;
                procedure CharsAvailable;
                override;
                procedure SendLine (s: Str255);
                procedure LineAvailable (line: Str255);
                procedure CheckLineAvailable; { You can override this and use input_buffer yourself }
            end;

{$ifc not do_debug}
{$definec AssertValidConnection(c) }
{$elsec}
{$definec AssertValidConnection(c) AssertValidConnectionCode(c)}
{$endc}

{$ifc do_debug}
    procedure AssertValidConnectionCode( connection: ConnectionBaseObject );
{$endc}

    procedure StartupConnections;
    procedure FinishConnections;
    function ValidConnection( connection: ConnectionBaseObject ): boolean;

implementation

    uses
        Devices, TextUtils, Memory, Events,
        MyLowLevel,
        DNR, MyStrings, MyMemory, MyMathUtils, MyIPStrings, TCPUtils, MyStartup;

{$ifc undefined objects_are_handles}
{$setc objects_are_handles := 1}
{$endc}

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

    const  { Tuning parameters }
        connections_max = 128;
        TO_FindAddress = 40 * second_in_ticks;
        TO_FindName = 40 * second_in_ticks;
        TO_ActiveOpen = 20 * second_in_ticks;
        TO_Closing = longint(2) * minute_in_ticks;
        TO_PassiveOpen = longint(1) * 365 * day_in_ticks;  { One years should be safe enough right? :-) }

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

{$ifc do_debug}
    var
        startup_check: integer;
{$endc}

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

    function ValidConnection( connection: ConnectionBaseObject ): boolean;
        var
            i: integer;
    begin
        ValidConnection := false;
        for i := 1 to max_connections do begin
            if connections[i] = connection then begin
                ValidConnection := true;
                leave;
            end;
        end;
    end;

{$ifc do_debug}
    procedure AssertValidConnectionCode( connection: ConnectionBaseObject );
    begin
        Assert( ValidConnection( connection ) );
    end;
{$endc}

    function ConnectionBaseObject.Create: OSStatus;
        var
            i: integer;
            err: OSStatus;
    begin
        AssertDidStartup( startup_check );
{$ifc objects_are_handles}
        LockHigh(Handle(self));
{$endc}

        hack_test_bad_connections := false;
        hack_do_test_bad_connections := false;

        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 <= connections_max) & (connections[i] <> nil) do begin
                i := i + 1;
            end;
            if i <= connections_max then begin
                timetodie := false;
                connection_index := i;
                max_connections := Max( max_connections, 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: OSStatus);
    begin
{$unused(err)}
        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: OSStatus;
    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
{$unused(ip)}
    end;

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

    procedure NameSearchObject.FindName (hostIP: longint);
        var
            err: OSStatus;
    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: OSStatus);
    begin
{$unused(name, error)}
    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
                if result <> noErr then begin
                    IPAddrToString( ip, name );
                end;
                FoundName(name, result);
                timetodie := true;
            end;
        end;
    end;

    function ListenerObject.Create: OSStatus;
    begin
        listener := nil;
        localport := 0;
        Create := inherited Create;
    end;

    procedure ListenerObject.Destroy;
    begin
        if listener <> nil then begin
            TransportDestroyListener( listener );
        end;
        inherited Destroy;
    end;

    function ListenerObject.CreateListener(buffersize:longint; port:ipPort; listeners:integer): OSStatus;
        var
            err: OSStatus;
    begin
        err := Create;
        if err = noErr then begin
            localport := port;
            err := TransportListen( listener, localport, listeners, buffersize);
            timeout_time := maxLongInt;
        end;
        if err <> noErr then begin
            timetodie := true;
        end;
        CreateListener := err;
    end;

    procedure ListenerObject.ConnectionAvailable( connection: TransportRef );
    begin
        TransportDestroy( connection );
    end;

    procedure ListenerObject.HandleConnection;
        var
            connection:TransportRef;
    begin
        if TransportGetListenerConnection( listener, connection ) = noErr then begin
            ConnectionAvailable( connection );
        end;
        inherited HandleConnection;
    end;

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

    function UDPObject.CreatePort (buffersize: longint; port: ipPort): OSStatus;
        var
            err: OSStatus;
    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: ipAddr; remoteport: ipPort; datap: Ptr; datalen: integer);
    begin
{$unused(remoteip, remoteport, datap, datalen)}
    end;

    procedure UDPObject.PacketsAvailable (count: integer);
        var
            err: OSStatus;
            remoteip: longint;
            remoteport: ipPort;
            datap: Ptr;
            datalen: integer;
    begin
{$unused(count)}
        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: ipPort; datap: Ptr; datalen: integer; checksum: boolean): OSStatus;
    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: OSStatus;
        var
            err, err2:OSStatus;
    begin
        err := inherited Create;
        status := CS_None;
        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: OSStatus;
    begin
        if ((status = CS_Established) or (status = CS_Closing)) and not closedone then begin
            err := PtrAndHand(datap, output_buffer, len);
        end else begin
            err := -24;
        end;
        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 := MGetHandleSize(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 := MGetHandleSize(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;
            timeout_time := TickCount + TO_Closing;
            TransportSendClose(tref);
        end;
    end;

    procedure ConnectionObject.BeginConnection;
    begin
    end;

    procedure ConnectionObject.NewExistingConnection(newtref: TransportRef);
        var
            err: OSStatus;
    begin
        err := Create;
        tref := newtref;
        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: ipPort; remotehost: Str255);
        var
            err: OSStatus;
    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: ipPort);
    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 MGetHandleSize(output_buffer) > 0 then begin
                do_send_close := true;
            end else begin
                timeout_time := TickCount + TO_Closing;
                TransportSendClose(tref);
            end;
        end;
        closedone := true;
    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
                        status := CS_Established;
                        timeout_time := maxLongInt;
                        Established;
                    end else if result <> inProgress then begin
                        Failed(result);
                        timetodie := true;
                    end;
                end;
                CS_Established:  begin
                    DoTransfer;
                    state := TransportGetConnectionState(tref);

                    if hack_test_bad_connections then begin
                        state := T_Dead;
                    end;

                    case state of
                        T_Established:  begin
                            if MGetHandleSize(input_buffer) > 0 then begin
                                CharsAvailable;

                                if hack_do_test_bad_connections & (band( Random(), 31 ) = 1) then begin
                                    hack_test_bad_connections := true;
                                end;

                            end;
                        end;
                        T_PleaseClose, T_Closing:  begin
                            if MGetHandleSize(input_buffer) > 0 then begin
                                CharsAvailable;
                            end else begin
                                status := CS_Closing;
                                timeout_time := TickCount + TO_Closing;
                                Closing;
                            end;
                        end;
                        T_Dead, T_Bored:  begin
                            status := CS_Closing;
                            timeout_time := TickCount + TO_Closing;
                            Closing;
                        end;
                        otherwise
                            ;
                    end;
                end;
                CS_Closing:  begin
                    DoTransfer;
                    state := TransportGetConnectionState(tref);

                    if hack_test_bad_connections then begin
                        state := T_Dead;
                    end;

                    case state of
                        T_PleaseClose, T_Closing, T_Established:  begin
                            if MGetHandleSize(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: OSStatus;
    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
{$unused(line)}
    end;

    procedure LineConnectionObject.CharsAvailable;
    begin
        CheckLineAvailable;
    end;

    procedure LineConnectionObject.CheckLineAvailable;
        var
            len, inbuf: longint;
            p: Ptr;
            s: Str255;
    begin
        while true do begin
            inbuf := MGetHandleSize(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;
                MMungerDelete(input_buffer, 0, len);
                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 DestroyAll( fail: Boolean );
        var
            i: integer;
    begin
        for i := 1 to max_connections do begin
            if connections[i] <> nil then begin
                if fail then begin
                    connections[i].Failed( kOTClientNotInittedErr );
                end;
                connections[i].Destroy;
            end;
        end;
        max_connections := 0;
    end;

    procedure FinishConnections;
    begin
        quiting := true;
        DestroyAll( false );
    end;

    procedure TransitionNotifier( up: boolean );
    begin
        if not up then begin
            DestroyAll( true );
        end;
    end;

    function InitConnections( var msg: integer ): OSStatus;
        var
            i: integer;
    begin
{$unused(msg)}
        DidStartup( startup_check );
        TransportInstallTransitionNotifier( TransitionNotifier );
        quiting := false;
        for i := 1 to connections_max do begin
            connections[i] := nil;
        end;
        max_connections := 0;
        InitConnections := noErr;
    end;

    procedure StartupConnections;
    begin
        StartupTransport;
        SetStartup(InitConnections, IdleConnections, 0, FinishConnections);
    end;

end.