Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/FetchNews 1.0.0b/source/TCPStuff.unit

Text File | 1993-02-23 | 22.9 KB | 787 lines | [TEXT/PJMM]

unit TCPStuff;

{ TCPStuff © Peter Lewis, Oct 1991 }
{ This source is Freeware }

interface

    uses
        TCPTypes;

    const
        Minimum_TCPBUFFERSIZE = 4096;
        Default_TCPBUFFERSIZE = longInt(6) * 1024;
    { Amount of space to allocate for each TCP connection }
        INCOMINGBUFSIZE = 100;    { Incoming buffer size, used for buffering ReceiveUpTo. }
        control_block_max = 260;
        tooManyControlBlocks = -23098;

    type
        OSErrPtr = ^OSErr;

{ TCP connection description: }
        TCPConnectionType = record
                magic: OSType;    { A magic number to try and avoid problems with released connection IDs. }
                stream: StreamPtr;
                closedone: boolean;
                laststate: integer;
                asends, asendcompletes: longInt;
                closeuserptr: OSErrPtr;
                incomingPtr: Ptr;                                { Pointer into inBuf of next byte to read. }
                incomingSize: longInt;                        { Number of bytes left in inBuf. }
                buffer: ptr;        { connection buffer. }
                inBuf: array[1..INCOMINGBUFSIZE] of SignedByte;    {Input buffer. }
            end;
        TCPConnectionPtr = ^TCPConnectionType;

        MyControlBlock = record
                tcp: TCPControlBlock;
                inuse: boolean;
                userptr: OSErrPtr;
                proc: procPtr;
                tcpc: TCPConnectionPtr;
            end;
        MyControlBlockPtr = ^MyControlBlock;


        TCPStateType = (T_WaitingForOpen, T_Closed, T_Listening, T_Opening, T_Established,{}
            T_Closing, T_PleaseClose, T_Unknown);

    function TCPNameToAddr (var hostName: str255; timeout: longInt): longInt;
    function TCPOpenResolver (var dataptr: ptr): OSErr;
    function TCPStrToAddr (dataptr: ptr; var hostName: str255; var rtnStruct: hostInfo; var done: signedByte): OSErr;
    procedure TCPAddrToStr (dataptr: ptr; addr: longInt; var addrStr: str255);
    function TCPAddrToName (dataptr: ptr; addr: longInt; var rtnStruct: hostInfo; var done: signedByte): OSErr;
    procedure TCPCloseResolver (dataptr: ptr);

    function C2PStr (s: stringPtr): stringPtr;
    procedure SanitizeHostName (var s: str255);

    function TCPInit: OSErr;
    procedure TCPFinish;
    function TCPGetMyIPAddr (var myIP: longInt): OSErr;
    function TCPActiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    function TCPPassiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: streamPtr): OSErr;
    function TCPFlush (connection: TCPConnectionptr): OSErr;
    function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
    function TCPAbort (connection: TCPConnectionPtr): OSErr;
    function TCPRelease (var connection: TCPConnectionPtr): OSErr;
    procedure TCPRawState (connection: TCPConnectionPtr; var state: integer; var localhost: longInt; var localport: integer; var remotehost: longInt; var remoteport: integer; var available: longInt);
    function TCPState (connection: TCPConnectionPtr): TCPStateType;
    function TCPCharsAvailable (connection: TCPConnectionPtr): longInt;
    function TCPLocalPort (connection: TCPConnectionPtr): integer;
    function TCPRawReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
{ Use EITHER RawReceive, or the other Receives.  Don't combine them for one stream! }
    function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
    function TCPReadByte (connection: TCPConnectionPtr; timeout: longInt; var b: SignedByte): OSErr;
    function TCPReceiveUpTo (connection: TCPConnectionPtr; termChar: signedByte;{}
                                    charTimeOut: longInt; readPtr: ptr; readSize: longInt; var readPos: longInt;{}
                                    var gottermchar: boolean): OSErr;
    function TCPSend (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean): OSErr;
    function TCPSendAsync (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean; userptr: OSErrPtr): OSErr;

    procedure ZeroCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);

implementation

    const
        MAGICNUMBER = 'TMGK';    { Unique value used to trap illegal connection IDs. }
        dispose_block_max = 100;

    type
        MyControlBlockArray = array[1..control_block_max] of MyControlBlockPtr;

    var
        driver_refnum: integer;
        controlblocks: MyControlBlockArray;
        disposeblocks: array[1..dispose_block_max] of ptr;

    procedure SanitizeHostName (var s: str255);
        var
            dummysp: stringPtr;
    begin
        dummysp := C2PStr(@s);
{$PUSH}
{$R-}
        if s[Length(s)] = '.' then
            s[0] := chr(Length(s) - 1);
{$POP}
    end;

    function GetA6: ptr;
    inline
        $2F4E, $0000;

    procedure CallCompletion (cbp: MyControlBlockPtr; addr: procPtr);
    inline
        $205F, $4E90;

{$PUSH}
{$D-}
    procedure IOCompletion; { All C functions look like pascal paramterless procedures from the procs point of view }
        type
            stackframe = packed record
                    frameptr: ptr;
                    returnptr: ptr;
                    paramblockptr: MyControlBlockPtr;
                end;
            stackframeptr = ^stackframe;
        var
            a6: stackframeptr;
            cbp: MyControlBlockPtr;
    begin
        a6 := stackframeptr(GetA6);
        cbp := a6^.paramblockptr;
        with cbp^ do begin
            if userptr <> nil then
                userptr^ := cbp^.tcp.ioResult;
            inuse := false;
            if proc <> nil then
                CallCompletion(cbp, proc);
        end;
    end;

    procedure ZotBlocks;
        var
            i: integer;
    begin
        for i := 1 to dispose_block_max do begin
            if disposeblocks[i] <> nil then begin
                DisposePtr(disposeblocks[i]);
                disposeblocks[i] := nil;
            end;
        end;
    end;

    procedure AddBlock (p: univ ptr);
{ Called at interupt level }
{ Must work even while ZotBlocks is in progress }
        var
            i: integer;
    begin
        for i := 1 to dispose_block_max do begin
            if disposeblocks[i] = nil then begin
                disposeblocks[i] := p;
                leave;
            end;
        end;
    end;

    procedure ZeroCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
    { Zero out the control block parameters. }
        var
            i: integer;
            p: longInt;
    begin
        ZotBlocks;
        for p := longInt(@cb) to longInt(@cb) + SizeOf(TCPControlBlock) - 1 do
            ptr(p)^ := 0;
        cb.tcpStream := stream;
        cb.ioCRefNum := driver_refnum;
        cb.csCode := call;
    end;

    function GetCB (var cbp: MyControlBlockPtr; tcpc: TCPConnectionPtr; call: integer; userptr: OSErrPtr; proc: procptr): OSErr;
{ NOTE: Must not move memory if there is a free block available (ie, during a Completion call) }
        var
            i: integer;
    begin
        i := 1;
        while (i < control_block_max) & (controlblocks[i] <> nil) & controlblocks[i]^.inuse do
            i := i + 1;
        cbp := controlblocks[i];
        if cbp = nil then begin
            cbp := MyControlBlockPtr(NewPtr(SizeOf(MyControlBlock)));
            if cbp <> nil then begin
                cbp^.inuse := false;
                controlblocks[i] := cbp;
            end;
        end;
        if (cbp <> nil) & not cbp^.inuse then begin
            ZeroCB(cbp^.tcp, tcpc^.stream, call);
            cbp^.tcp.ioCompletion := @IOCompletion;
            cbp^.inuse := true;
            cbp^.userptr := userptr;
            cbp^.tcpc := tcpc;
            cbp^.proc := proc;
            if userptr <> nil then
                userptr^ := inprogress;
            GetCB := noErr;
        end
        else begin
            cbp := nil;
            GetCB := memFullErr;
        end;
    end;

    procedure FreeCB (var cbp: MyControlBlockPtr);
    begin
        if cbp <> nil then
            cbp^.inuse := false;
        cbp := nil;
    end;
{$POP}

{$S Init}
    function TCPInit: OSErr;
        var
            oe: OSErr;
            i: integer;
    begin
        oe := OpenDriver('.IPP', driver_refnum);
        for i := 1 to control_block_max do
            controlblocks[i] := nil;
        TCPInit := oe;
    end;

{$S Term}
    procedure TCPFinish;
        var
            i: integer;
    begin
        for i := 1 to control_block_max do
            if controlblocks[i] <> nil then begin
                DisposPtr(ptr(controlblocks[i]));
                controlblocks[i] := nil;
            end;
    end;

{$S}
    procedure DestroyConnection (var connection: TCPConnectionPtr);
    begin
        connection^.magic := '????';
        if connection^.buffer <> nil then
            DisposPtr(ptr(connection^.buffer));
        DisposPtr(Ptr(connection));
        connection := nil;
    end;

    function ValidateConnection (connection: TCPConnectionPtr): OSErr;
    begin
        if connection = nil then
            ValidateConnection := connectionDoesntExist
        else if connection^.magic <> MAGICNUMBER then
            ValidateConnection := connectionDoesntExist
        else
            ValidateConnection := noErr;
    end;

    function PBControlSync (var cb: TCPControlBlock): OSErr;
    begin
        PBControlSync := PBControl(@cb, false);
    end;

{$PUSH}
{$D-}
    function PBControlAsync (var cbp: MyControlBlockPtr): OSErr;
        var
            oe: OSErr;
    begin
        oe := PBControl(ParmBlkPtr(cbp), true);
        if oe <> noErr then
            FreeCB(cbp);
        PBControlAsync := oe;
    end;
{$POP}

    function TCPGetMyIPAddr (var myIP: longInt): OSErr;
        var
            cb: TCPControlBlock;
            oe: OSErr;
    begin
        ZeroCB(cb, nil, TCPcsGetMyIP);
        oe := PBControlSync(cb);
        myIP := cb.getmyip.ourAddress;
        TCPGetMyIPAddr := oe;
    end;

    procedure SetUserPtr (userptr: OSErrPtr; oe: OSErr);
    begin
        if userptr <> nil then begin
            if oe <> noErr then
                userptr^ := oe;
        end;
    end;

    function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: streamPtr): OSErr;
        var
            oe: OSErr;
    begin
        connection := TCPConnectionPtr(NewPtr(sizeof(TCPConnectionType)));
        if connection = nil then
            oe := memFullErr
        else begin
            oe := noErr;
            with connection^ do begin
                buffer := nil;
                magic := MAGICNUMBER;
                asends := 0;
                asendcompletes := 0;
                closedone := false;
                incomingSize := 0;
                stream := strm;
            end;
        end;
        if (oe <> noErr) and (connection <> nil) then
            DestroyConnection(connection);
        TCPCreateConnectionForStream := oe;
    end;

    function CreateStream (var connection: TCPConnectionPtr; buffersize: longInt): OSErr;
        var
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        connection := TCPConnectionPtr(NewPtr(sizeof(TCPConnectionType)));
        if connection = nil then
            oe := memFullErr
        else
            with connection^ do begin
                buffer := NewPtr(buffersize);
                if buffer = nil then begin
                    oe := memFullErr;
                    DisposPtr(ptr(connection));
                    connection := nil;
                end
                else begin
                    magic := MAGICNUMBER;
                    asends := 0;
                    asendcompletes := 0;
                    closedone := false;
                    incomingSize := 0;
                    ZeroCB(cb, nil, TCPcsCreate);
                    cb.create.rcvBuff := buffer;
                    cb.create.rcvBuffLen := buffersize;
                    oe := PBControlSync(cb);
                    stream := cb.tcpStream;
                end;
            end;
        if (oe <> noErr) and (connection <> nil) then
            DestroyConnection(connection);
        CreateStream := oe;
    end;

    function PAOpen (var connection: TCPConnectionPtr; cs: integer; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
        var
            oe, ooe: OSErr;
            cbp: MyControlBlockPtr;
            cb: TCPControlBlock;
    begin
        oe := CreateStream(connection, buffersize);
        if oe = noErr then begin
            with connection^ do begin
                oe := GetCB(cbp, connection, cs, userptr, nil);
                if oe = noErr then begin
                    cbp^.tcp.open.localPort := localPort;
                    cbp^.tcp.open.remoteHost := remoteIP;
                    cbp^.tcp.open.remotePort := remoteport;
                    oe := PBControlAsync(cbp);
                end;
                if oe <> noErr then begin
                    ZeroCB(cb, stream, TCPcsRelease);
                    ooe := PBControlSync(cb);
                    DestroyConnection(connection);
                end;
            end;
        end;
        SetUserPtr(userptr, oe);
        PAOpen := oe;
    end;

{ Open a connection to another machine }
    function TCPActiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    begin
        TCPActiveOpen := PAOpen(connection, TCPcsActiveOpen, buffersize, localport, remoteIP, remoteport, userptr);
    end;

{ Open a socket on this machine, to wait for a connection }
    function TCPPassiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    begin
        TCPPassiveOpen := PAOpen(connection, TCPcsPassiveOpen, buffersize, localport, remoteIP, remoteport, userptr);
    end;

    function TCPRawReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
{ Return readCount characters from the TCP connection. }
{ WARNING: Doesnt handle incoming buffer, so don't use with TCPReceiveUptp or ReadByte }
        var
            cb: TCPControlBlock;
            oe: OSErr;
    begin
        repeat
            ZeroCB(cb, connection^.stream, TCPcsRcv);
            cb.receive.rcvBuff := returnPtr;
            cb.receive.rcvBuffLength := readCount;
            oe := PBControlSync(cb);
            longInt(returnPtr) := longInt(returnPtr) + cb.receive.rcvBuffLength;
            readCount := readCount - cb.receive.rcvBuffLength;
        until (oe <> noErr) or (readCount = 0);
        TCPRawReceiveChars := oe;
    end;

{ Return readCount characters from the TCP connection.}
    function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
        var
            readCountStr: Str255;
            l: longInt;
            p: Ptr;
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then
            if readCount < 0 then
                oe := invalidLength
            else if readCount > 0 then begin
                p := returnPtr;
                with connection^ do
                    if incomingSize > 0 then begin
            { Read as much as there is or as much as we need, whichever is less. }
                        if readCount < incomingSize then
                            l := readCount
                        else
                            l := incomingSize;
                        BlockMove(incomingPtr, p, l);
                        incomingPtr := Ptr(ord4(incomingPtr) + l);
                        incomingSize := incomingSize - l;
                        p := Ptr(ord4(p) + l);
                        readCount := readCount - l;
                    end;
                { If there's more needed, then read it from the connection. }
                if readCount > 0 then begin
                        { Issue a read and wait until it all arrives). }
                    oe := TCPRawReceiveChars(connection, p, readCount);
                end;
            end;
        TCPReceiveChars := oe;
    end;

    function TCPReadByte (connection: TCPConnectionPtr; timeout: longInt; var b: SignedByte): OSErr;
        { Return the next byte in the buffer, reading more in if necessary. }
        var
            waitUntil: longInt;
            readIn: longInt;
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then
            with connection^ do begin            { Check if we need to read in more bytes. }
                if incomingSize = 0 then begin
                    if (timeout = 0) and (TCPCharsAvailable(connection) = 0) then
                        oe := commandTimeout
                    else begin
                        waitUntil := TickCount + timeout;
    { keep on trying to read until we get at least one, or the time-out happens. }
                        while (oe = noErr) and (incomingSize = 0) do begin                { Get the status. }
                            readIn := TCPCharsAvailable(connection);    { If there's something there to read, do so. }
                            if readIn > 0 then begin    { Don't read any more than will fit in the buffer. }
                                if readIn > INCOMINGBUFSIZE then
                                    readIn := INCOMINGBUFSIZE;
                        { Issue the read. }
                                oe := TCPRawReceiveChars(connection, @inBuf, readIn);
                                if oe = noErr then begin
                                    incomingSize := readIn;
                                    incomingPtr := @inBuf;
                                end;
                            end        { If not, do another round or get out, depending on the timeout condition. }
                            else if TickCount > waitUntil then begin
                                oe := commandTimeOut;
                            end;
                        end;
                    end;
                end;
                { Get the byte to return. }
                if incomingSize > 0 then begin
                    b := incomingPtr^;
                    incomingPtr := Ptr(ord4(incomingPtr) + 1);
                    incomingSize := incomingSize - 1;
                end
                else
                    b := 0;
            end;
        TCPReadByte := oe;
    end;

{ Pass in a block of memory (readPtr,readSize), already containing readPos bytes}
{ TCPReceiveUpTo will then read characters until a termChar character is reached,}
{ or until waitForChars ticks go by without receiving any bytes.  If waitForChars is}
{ zero, then TCPReceiveUpTo will return immediately.  If termChar=0, then it}
{ will read the entire buffer, and any characters that arrive before a timeout }
    function TCPReceiveUpTo (connection: TCPConnectionPtr; termChar: signedByte;{}
                                    charTimeOut: longInt; readPtr: ptr; readSize: longInt; var readPos: longInt;{}
                                    var gottermchar: boolean): OSErr;
        var
            oe: OSErr;
            inChar: SignedByte;
            p: Ptr;
    begin
        oe := ValidateConnection(connection);
        gottermchar := false;
        if oe = noErr then begin
{ Cycle until the timeout happens or we see the termintor character or we run out of room. }
            while (oe = noErr) and (readPos < readSize) and not gottermchar do begin            { Get the next character. }
                oe := TCPReadByte(connection, charTimeOut, inChar);                    { Ignore the character if it's a zero. }
                if (oe = noErr) and (inChar <> 0) then begin            { Put it in the result. }
                    p := Ptr(ord4(readPtr) + readPos);
                    p^ := inChar;
                    readPos := readPos + 1;
                    gottermchar := inChar = termChar;
                end;
            end;
            if oe = commandTimeOut then
                oe := noErr;
        end;
        TCPReceiveUpTo := oe;
    end;

    function TCPSend (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean): OSErr;
        var
            wds: wdsType;
            oe: OSErr;
            cb: TCPControlBlock;
            p: ptr;
    begin
        oe := ValidateConnection(connection);
        if oe = nOErr then
            if writeCount > 0 then begin
                wds.buffer := writePtr;
                wds.size := writeCount;
                wds.term := 0;
                ZeroCB(cb, connection^.stream, TCPcsSend);
                cb.send.wds := @wds;
                cb.send.pushFalg := ord(push);
                oe := PBControlSync(cb);
            end
            else if writeCount < 0 then
                oe := InvalidLength;
        TCPSend := oe;
    end;

{$PUSH}
{$D-}
    procedure TCPSendComplete (cbp: MyControlBlockPtr);
        var
            oe: OSErr;
    begin
        AddBlock(cbp^.tcp.send.wds);
        with cbp^.tcpc^ do begin
            asendcompletes := asendcompletes + 1;
            if (asendcompletes = asends) and closedone then begin
                oe := GetCB(cbp, cbp^.tcpc, TCPcsClose, closeuserptr, nil);
{ GetCB won't NewPtr because the completion has just released a block }
                if oe = noErr then begin
                    oe := PBControlAsync(cbp);
                end;
            end;
        end;
    end;
{$POP}

    function TCPSendAsync (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean; userptr: OSErrPtr): OSErr;
        type
            myblock = record
                    wds: wdsType;
                    data: array[0..100] of byte;
                end;
            myblockptr = ^myblock;
        var
            oe: OSErr;
            cbp: MyControlBlockPtr;
            p: myblockptr;
    begin
        oe := ValidateConnection(connection);
        if oe = nOErr then
            if writeCount > 0 then begin
                p := myblockptr(NewPtr(writeCount + SizeOf(wdsType)));
                if p = nil then
                    oe := memFullErr
                else begin
                    p^.wds.buffer := @p^.data;
                    p^.wds.size := writeCount;
                    p^.wds.term := 0;
                    with p^.wds do
                        BlockMove(writePtr, buffer, size);
                    oe := GetCB(cbp, connection, TCPcsSend, userptr, @TCPSendComplete);
                    cbp^.tcp.send.wds := POINTER(p);
                    cbp^.tcp.send.pushFalg := ord(push);
                    with connection^ do
                        asends := asends + 1;
                    oe := PBControlAsync(cbp);
                    if oe <> noErr then
                        DisposPtr(ptr(p));
                end;
            end
            else if writeCount < 0 then
                oe := InvalidLength;
        TCPSendAsync := oe;
    end;

    function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
        var
            oe: OSErr;
            cbp: MyControlBlockPtr;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then
            with connection^ do begin
                closeuserptr := userptr;
                if userptr <> nil then
                    userptr^ := inProgress;
                closedone := true;
                if asends = asendcompletes then begin
                    oe := GetCB(cbp, connection, TCPcsClose, userptr, nil);
                    if oe = noErr then begin
                        oe := PBControlAsync(cbp);
                    end;
                end;
            end;
        SetUserPtr(userptr, oe);
        TCPClose := oe;
    end;

    function TCPAbort (connection: TCPConnectionPtr): OSErr;
        var
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            ZeroCB(cb, connection^.stream, TCPcsAbort);
            oe := PBControlSync(cb);
        end;
        TCPAbort := oe;
    end;

{ Release the TCP stream, including the buffer.}
    function TCPRelease (var connection: TCPConnectionPtr): OSErr;
        var
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            ZeroCB(cb, connection^.stream, TCPcsRelease);
            oe := PBControlSync(cb);
            DestroyConnection(connection);
        end;
        TCPRelease := oe;
    end;

{    TCPRawState(connectionID) -- Return the state of the TCP connection.}
    procedure TCPRawState (connection: TCPConnectionPtr; var state: integer; var localhost: longInt; var localport: integer; var remotehost: longInt; var remoteport: integer; var available: longInt);
        var
            cb: TCPControlBlock;
            oe: OSErr;
    begin
        oe := ValidateConnection(connection);
        localhost := 0;
        localport := 0;
        remotehost := 0;
        remoteport := 0;
        available := 0;
        if oe <> noErr then begin
            state := 99; { Error -> Closed }
        end
        else begin
            ZeroCB(cb, connection^.stream, TCPcsStatus);
            if PBControlSync(cb) <> noErr then begin
                state := 99; { Closed }
            end
            else begin
                state := cb.status.connectionState;
                connection^.laststate := state;
                localhost := cb.status.localhost;
                localport := cb.status.localport;
                remotehost := cb.status.remotehost;
                remoteport := cb.status.remoteport;
                available := cb.status.amtUnreadData + connection^.incomingSize;
            end;
        end;
    end;

{ Return the state of the TCP connection.}
    function TCPState (connection: TCPConnectionPtr): TCPStateType;
        var
            state: integer;
            localhost: longInt;
            localport: integer;
            remotehost: longInt;
            remoteport: integer;
            available: longInt;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        case state of
            0:
                TCPState := T_Closed;
            2:
                TCPState := T_Listening;
            4, 6:
                TCPState := T_Opening;
            8:
                TCPState := T_Established;
            10, 12, 16, 18, 20:
                TCPState := T_Closing;
            14:
                TCPState := T_PleaseClose;
            98:
                TCPState := T_WaitingForOpen;
            99:
                TCPState := T_Closed;
            otherwise
                TCPState := T_Unknown;
        end;
    end;

{    Return the number of characters available for reading from the TCP connection.}
    function TCPCharsAvailable (connection: TCPConnectionPtr): longInt;
        var
            state: integer;
            localhost: longInt;
            localport: integer;
            remotehost: longInt;
            remoteport: integer;
            available: longInt;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        TCPCharsAvailable := available;
    end;

    function TCPLocalPort (connection: TCPConnectionPtr): integer;
        var
            state: integer;
            localhost: longInt;
            localport: integer;
            remotehost: longInt;
            remoteport: integer;
            available: longInt;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        TCPLocalPort := localport;
    end;

    function TCPFlush (connection: TCPConnectionptr): OSErr;
        var
            buffer: array[0..255] of signedByte;
            f: longInt;
            oe: OSErr;
    begin
        f := TCPCharsAvailable(connection);
        oe := noErr;
        while (f > 0) and (oe = noErr) do begin
            if f > 256 then
                f := 256;
            oe := TCPReceiveChars(connection, @buffer, f);
            if oe = noErr then
                f := TCPCharsAvailable(connection);
        end;
        TCPFlush := oe;
    end;

end.
function TCPNameToAddr (var hostName: str255; timeout: longInt; var hostFile: str255): longInt;
    function TCPOpenResolver (var hostFile: str255; var dataptr: ptr): OSErr;
        function TCPStrToAddr (dataptr: ptr; var hostName: str255; var rtnStruct: hostInfo; var done: signedByte): OSErr;
            procedure TCPAddrToStr (dataptr: ptr; addr: longInt; var addrStr: str255);
                function TCPAddrToName (dataptr: ptr; addr: longInt; var rtnStruct: hostInfo; var done: signedByte): OSErr;
                    procedure TCPCloseResolver (dataptr: ptr);