Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Pascal/Applications/ircle 1.5.1/source/TCP Libraries/TCPStuff.unit

Text File | 1993-03-15 | 23.2 KB | 797 lines | [TEXT/PJMM]

unit TCPStuff;

{ From Peter's PNL Libraries }
{ Copyright 1992 Peter N Lewis }
{ This source may be used for any non-commercial purposes as long as I get a mention }
{ in the About box and Docs of any derivative program.  It may not be used in any commercial }
{ application without my permission }

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;

implementation

{    Loosely based on code by Harry Chesley 12/88, thus Copyright © 1988 Apple Computer, Inc.}
{    Converted to sensible pascal interface 7/91 by Peter Lewis, thus also Copyright © 1991 Peter Lewis }

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;
    max_dispose_block: integer;
    disposeblocks: array[1..dispose_block_max] of ptr;

function C2PStr (s: StringPtr): StringPtr; { I've added this since it seems to be missing?  -oti }
    var
        n, i: integer;
    begin
        n := 0;
        while s^[n] <> chr(0) do
            n := succ(n);
        for i := n downto 1 do
            s^[i - 1] := s^[i];
        s^[0] := chr(n);
        C2PStr := s
    end;


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;
    begin
        while max_dispose_block > 0 do begin
            DisposPtr(disposeblocks[max_dispose_block]);
            max_dispose_block := max_dispose_block - 1;
        end;
    end;

procedure AddBlock (p: univ ptr);
    begin
        if max_dispose_block < dispose_block_max then begin
            max_dispose_block := max_dispose_block + 1;
            disposeblocks[max_dispose_block] := p;
        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
        max_dispose_block := 0;
        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);