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

Text File | 1997-05-29 | 32.7 KB | 1,136 lines | [TEXT/CWIE]

unit TCPStuff;

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

interface

    uses
        TextUtils, TCPTypes, TCPUtils;

    const
    { 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;

    type
        UDPConnectionRecord = record
                magic: OSType;    { A magic number to try and avoid problems with released connection IDs. }
                stream: StreamPtr;
                outstanding: integer;
            end;
        UDPConnectionPtr = ^UDPConnectionRecord;

    var
        icmp_sent_out, icmp_got_back: longint;
        largest_mtu: longint;
        largest_minimum_tcp_buffer_size: longint;

    procedure StartupTCPStuff;

    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 TCPPassiveOpenDynamic (var connection: TCPConnectionPtr; buffersize: longint; var 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 TCPRemoteIP (connection: TCPConnectionPtr): ipAddr;
    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;

    function UDPCreate (var connection: UDPConnectionPtr; buffer_size: longint; var localport: integer): OSErr;
    function UDPRead (connection: UDPConnectionPtr; timeout: integer; var remoteIP: longint; var remoteport: integer;
                                    var datap: Ptr; var datalen: integer): OSErr;
    function UDPReturnBuffer (connection: UDPConnectionPtr; datap: Ptr): OSErr;
    function UDPDatagramsAvailable (connection: UDPConnectionPtr): integer;
    function UDPWrite (connection: UDPConnectionPtr; remoteIP: longint; remoteport: integer;
                                    datap: Ptr; datalen: integer; checksum: boolean): OSErr;
    function UDPRelease (var connection: UDPConnectionPtr): OSErr;
    function UDPMTU (remoteIP: longint; var mtu: longint): OSErr;

    function IPGetMyIPAddr (var myIP: ipAddr): OSErr;
    function IPSendICMPEcho (remotehost: ipAddr; timeout: integer; datap: Ptr; datalen: integer; complete: ProcPtr; userdata: univ Ptr; extradata: univ Ptr): OSErr;
{procedure ICMPCompletion (cbp: IPControlBlockPtr; userdata: Ptr;extradata:Ptr);}

    procedure UDPZeroCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
    procedure TCPControlAsync (pbp: TCPControlBlockPtr; comp: ProcPtr);
{ pbp MUST be a Ptr to an XTCPControlBlock }

    function GetMinimumBufferSize (remote_ip: ipAddr; tcp: boolean): longint;
    function GetBufferSize (remote_ip: ipAddr; desired: longint; tcp: boolean): longint;

implementation

    uses
        Memory, Errors, Devices, Events,
        DNR, MyMathUtils, MyCallProc, MyStartup, TCPUtils, MyMemory, MyTypes;

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

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

{$PUSH}
{$ALIGN MAC68K}

    type
        stackframe = packed record
                frameptr: Ptr;
                returnptr: Ptr;
                paramblockptr: Ptr;
            end;
        stackframeptr = ^stackframe;

{$ALIGN RESET}
{$POP}

    var
        controlblocks: MyControlBlockArray;
        disposeblocks: array[1..dispose_block_max] of Ptr;
        gTCPPreCompletionProc:UniversalProcPtr;
        gDoIOCompletionProc:UniversalProcPtr;
        gIPICMPCompletionProc:UniversalProcPtr;
        gTCPSendCompleteProc:UniversalProcPtr;
        gMyNotifyProc:UniversalProcPtr;

    const
        max_ICMPDataArray = 100;
    type
        ICMPData = record
                complete: ProcPtr;
                userdata: Ptr;
                extradata: Ptr;
            end;
        ICMPDataArray = array[1..max_ICMPDataArray] of ICMPData;
    var
        icmp_data_array: ICMPDataArray;

{$IFC not GENERATINGPOWERPC}
    function GetStackFrame: stackframeptr;
    inline
        $2E8E;
{$ENDC}

    procedure TCPPreCompletionPascal(pbp: TCPControlBlockPtr);
        var
            prp: TCPXControlBlockPtr;
    begin
        prp := TCPXControlBlockPtr(ord(pbp) - 4);
        if prp^.completion <> nil then begin
            CallPascal04(pbp, prp^.completion);
        end;
    end;

{$IFC GENERATINGPOWERPC}
    procedure TCPPreCompletion(pbp: TCPControlBlockPtr);
    begin
        TCPPreCompletionPascal(pbp);
    end;
{$ELSEC}
    procedure TCPPreCompletion; { All C functions look like pascal paramterless procedures from the procs Point of view }
    begin
        TCPPreCompletionPascal(TCPControlBlockPtr(GetStackFrame^.paramblockptr));
    end;
{$ENDC}

    procedure TCPControlAsync (pbp: TCPControlBlockPtr; comp: ProcPtr);
        var
            err: OSErr;
            prp: TCPXControlBlockPtr;
    begin
        prp := TCPXControlBlockPtr(ord(pbp) - 4);
        prp^.completion := comp;
        pbp^.ioCompletion := gTCPPreCompletionProc;
        err := PBControlAsync(ParmBlkPtr(pbp));
        if err <> noErr then begin
            pbp^.ioResult := err;
            if prp^.completion <> nil then begin
                CallPascal04(pbp, prp^.completion);
            end;
        end;
    end;

    procedure IOCompletionPascal (cbp: MyControlBlockPtr);
    begin
        with cbp^ do begin
            if userptr <> nil then begin
                userptr^ := cbp^.tcp.ioResult;
            end;
            inuse := false;
            if proc <> nil then begin
                CallPascal04(cbp, proc);
            end;
        end;
    end;

{$IFC GENERATINGPOWERPC}
    procedure DoIOCompletion (cbp: MyControlBlockPtr);
    begin
        IOCompletionPascal(cbp);
    end;
{$ELSEC}
    procedure DoIOCompletion; { All C functions look like pascal paramterless procedures from the procs Point of view }
    begin
        IOCompletionPascal(MyControlBlockPtr(GetStackFrame^.paramblockptr));
    end;
{$ENDC}

    procedure ZotBlocks;
        var
            i: integer;
    begin
        for i := 1 to dispose_block_max do begin
            if disposeblocks[i] <> nil then begin
                MDisposePtr(disposeblocks[i]);
            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);
    begin
        MZero(@cb, SizeOf(cb));
        cb.tcpStream := stream;
        cb.ioCRefNum := mactcp_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
            err: OSErr;
            i: integer;
    begin
        i := 1;
        while (i < control_block_max) & (controlblocks[i] <> nil) & controlblocks[i]^.inuse do begin
            i := i + 1;
        end;
        cbp := controlblocks[i];
        err := noErr;
        if cbp = nil then begin
            err := MNewPtr(cbp, SizeOf(MyControlBlock));
            if err = noErr then begin
                cbp^.inuse := false;
                controlblocks[i] := cbp;
            end;
        end;
        if (err = noErr) & not cbp^.inuse then begin
            ZeroCB(cbp^.tcp, tcpc^.stream, call);
            cbp^.tcp.ioCompletion := gDoIOCompletionProc;
            cbp^.inuse := true;
            cbp^.userptr := userptr;
            cbp^.tcpc := tcpc;
            cbp^.proc := proc;
            if userptr <> nil then begin
                userptr^ := inProgress;
            end;
            GetCB := noErr;
        end else begin
            cbp := nil;
            GetCB := memFullErr;
        end;
    end;

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

    function GetMinimumBufferSize (remote_ip: ipAddr; tcp: boolean): longint;
        var
            mtu: longint;
            err: OSErr;
            mult: integer;
    begin
        if tcp then begin
            mult := 4;
        end else begin
            mult := 2;
        end;
        err := noErr;
        if (remote_ip = 0) then begin
            err := IPGetMyIPAddr(remote_ip);
        end;
        if err = noErr then begin
            err := UDPMTU(remote_ip, mtu);
        end;
        if err <> noErr then begin
            mtu := largest_mtu;
        end;
        largest_mtu := Max(mtu, largest_mtu);
        largest_minimum_tcp_buffer_size := Max(4096, largest_mtu * 4 + 1024);
        GetMinimumBufferSize := Max(4096, mtu * mult + 1024);
    end;

    function GetBufferSize (remote_ip: ipAddr; desired: longint; tcp: boolean): longint;
        var
            minimum: longint;
    begin
        if desired = 0 then begin
            desired := 6 * 1024;
        end;
        minimum := GetMinimumBufferSize(remote_ip, tcp);
        GetBufferSize := Max(minimum, desired);
    end;

    procedure DestroyConnection (var connection: TCPConnectionPtr);
    begin
        connection^.magic := '????';
        if connection^.buffer <> nil then begin
            MDisposePtr(connection^.buffer);
        end;
        MDisposePtr(connection);
    end;

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

    function MyPBControlAsync (var cbp: MyControlBlockPtr): OSErr;
        var
            oe: OSErr;
    begin
        oe := PBControlAsync(ParmBlkPtr(cbp));
        if oe <> noErr then begin
            FreeCB(cbp);
        end;
        MyPBControlAsync := oe;
    end;

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

    function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: StreamPtr): OSErr;
        var
            oe: OSErr;
    begin
        oe := MNewPtr(connection, sizeof(TCPConnectionType));
        if oe = noErr then begin
            with connection^ do begin
                buffer := nil;
                magic := MAGICNUMBER;
                asends := 0;
                asendcompletes := 0;
                closedone := false;
                incomingSize := 0;
                stream := strm;
            end;
        end;
        TCPCreateConnectionForStream := oe;
    end;

    function CreateStream (var connection: TCPConnectionPtr; remoteIP: longint; buffersize: longint): OSErr;
        var
            oe: OSErr;
    begin
        buffersize := GetBufferSize(remoteIP, buffersize, true);
        oe := MNewPtr(connection, sizeof(TCPConnectionType));
        if oe = noErr then begin
            with connection^ do begin
                oe := MNewPtr(buffer, buffersize);
                if oe = noErr then begin
                    magic := MAGICNUMBER;
                    asends := 0;
                    asendcompletes := 0;
                    closedone := false;
                    incomingSize := 0;
                    ZotBlocks;
                    oe := MTTCPCreate(stream, buffer, buffersize);
                end;
            end;
            if (oe <> noErr) then begin
                DestroyConnection(connection);
            end;
        end;
        CreateStream := oe;
    end;

    function PAOpen (var connection: TCPConnectionPtr; cs: integer; buffersize: longint;var localport: integer; remoteIP: longint; remoteport: integer; userptr: OSErrPtr): OSErr;
        var
            oe, ooe: OSErr;
            cbp: MyControlBlockPtr;
    begin
        oe := CreateStream(connection, remoteIP, buffersize);
        if oe = noErr then begin
            with connection^ do begin
                ZotBlocks;
                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;
                    cbp^.tcp.open.ulpTimeoutAction := -1;
                    oe := MyPBControlAsync(cbp);
                    if (oe=noErr) & (cs=TCPcsPassiveOpen) then begin
                        while (cbp^.tcp.ioResult>=0) & (cbp^.tcp.open.localport=0) do begin
                            ;
                        end;
                        localport:=cbp^.tcp.open.localport;
                    end;
                end;
                if oe <> noErr then begin
                    ooe := MTTCPRelease(stream);
                    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;

{ Open a socket on this machine, to wait for a connection }
    function TCPPassiveOpenDynamic (var connection: TCPConnectionPtr; buffersize: longint; var localport: integer; remoteIP: longint; remoteport: integer; userptr: OSErrPtr): OSErr;
    begin
        TCPPassiveOpenDynamic := 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
        oe := noErr;
        while (oe = noErr) & (readCount > 0) do begin
            ZotBlocks;
            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;
        end;
        TCPRawReceiveChars := oe;
    end;

{ Return readCount characters from the TCP connection.}
    function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: Ptr; readCount: integer): OSErr;
        var
            l: longint;
            p: Ptr;
            oe: OSErr;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            if readCount < 0 then begin
                oe := invalidLengthErr;
            end else if readCount > 0 then begin
                p := returnPtr;
                with connection^ do begin
                    if incomingSize > 0 then begin
            { Read as much as there is or as much as we need, whichever is less. }
                        if readCount < incomingSize then begin
                            l := readCount;
                        end else begin
                            l := incomingSize;
                        end;
                        BlockMoveData(incomingPtr, p, l);
                        incomingPtr := Ptr(ord4(incomingPtr) + l);
                        incomingSize := incomingSize - l;
                        p := Ptr(ord4(p) + l);
                        readCount := readCount - l;
                    end;
                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;
        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;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            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 begin
                        oe := commandTimeoutErr;
                    end 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 begin
                                    readIn := INCOMINGBUFSIZE;
                                end;
                        { 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 := commandTimeoutErr;
                            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 begin
                    b := 0;
                end;
            end;
        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.  }
    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) then begin            { Put it in the result. }
                    p := Ptr(ord4(readPtr) + readPos);
                    p^ := inChar;
                    readPos := readPos + 1;
                    gottermchar := inChar = termChar;
                end;
            end;
            if oe = commandTimeoutErr then begin
                oe := noErr;
            end;
        end;
        TCPReceiveUpTo := oe;
    end;

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

    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 := MyPBControlAsync(cbp);
                end;
            end;
        end;
    end;

    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 begin
            if writeCount > 0 then begin
                oe := MNewPtr(p, writeCount + SizeOf(wdsType));
                if oe = noErr then begin
                    p^.wds.buffer := @p^.data;
                    p^.wds.size := writeCount;
                    p^.wds.term := 0;
                    with p^.wds do begin
                        BlockMoveData(writePtr, buffer, size);
                    end;
                    oe := GetCB(cbp, connection, TCPcsSend, userptr, gTCPSendCompleteProc);
                    cbp^.tcp.send.wds := POINTER(p);
                    cbp^.tcp.send.pushFlag := ord(push);
                    with connection^ do begin
                        asends := asends + 1;
                    end;
                    oe := MyPBControlAsync(cbp);
                    if oe <> noErr then begin
                        MDisposePtr(p);
                    end;
                end;
            end else if writeCount < 0 then begin
                oe := invalidLengthErr;
            end;
        end;
        TCPSendAsync := oe;
    end;

    function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
        var
            oe: OSErr;
            cbp: MyControlBlockPtr;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            with connection^ do begin
                if closedone then begin
                    if userptr <> nil then begin
                        userptr^ := noErr;
                    end;
                end else begin
                    closeuserptr := userptr;
                    if userptr <> nil then begin
                        userptr^ := inProgress;
                    end;
                    closedone := true;
                    if asends = asendcompletes then begin
                        ZotBlocks;
                        oe := GetCB(cbp, connection, TCPcsClose, userptr, nil);
                        if oe = noErr then begin
                            oe := MyPBControlAsync(cbp);
                        end;
                    end;
                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
            ZotBlocks;
            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;
    begin
        oe := noErr;
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            ZotBlocks;
            oe := MTTCPRelease(connection^.stream);
            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
        localhost := 0;
        localport := 0;
        remotehost := 0;
        remoteport := 0;
        available := 0;

        oe := ValidateConnection(connection);
        if oe <> noErr then begin
            state := 99; { Error -> Closed }
        end else begin
            ZotBlocks;
            ZeroCB(cb, connection^.stream, TCPcsStatus);
            oe := PBControlSync(@cb);
            if oe <> 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_Dead;
            2:
                TCPState := T_Bored;
            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_Dead;
            otherwise begin
                TCPState := T_Unknown;
            end;
        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 TCPRemoteIP (connection: TCPConnectionPtr): ipAddr;
        var
            state: integer;
            localhost: longint;
            localport: integer;
            remotehost: longint;
            remoteport: integer;
            available: longint;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        TCPRemoteIP := remotehost;
    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 begin
                f := 256;
            end;
            oe := TCPReceiveChars(connection, @buffer, f);
            if oe = noErr then begin
                f := TCPCharsAvailable(connection);
            end;
        end;
        TCPFlush := oe;
    end;

    procedure UDPZeroCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
    begin
        MZero(@cb, SizeOf(cb));
        cb.udpStream := stream;
        cb.ioCRefNum := mactcp_driver_refnum;
        cb.csCode := call;
    end;

    procedure MyNotify (stream: StreamPtr; eventCode: integer; connection: UDPConnectionPtr; icmpMsg: Ptr);
    begin
{$unused(stream, icmpMsg)}
        if eventCode = UDPDataArrival then begin
            if connection^.magic = UDPMagic then begin
                connection^.outstanding := connection^.outstanding + 1;
            end;
        end;
    end;

    function UDPCreate (var connection: UDPConnectionPtr; buffer_size: longint; var localport: integer): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        buffer_size := GetBufferSize(0, buffer_size, false);
        oe := MNewPtr(connection, SizeOf(UDPConnectionRecord) + buffer_size);
        if oe = noErr then begin
            connection^.magic := UDPMagic;
            UDPZeroCB(cb, nil, UDPcsCreate);
            cb.create.rcvBuff := Ptr(longint(connection) + SizeOf(UDPConnectionRecord));
            cb.create.rcvBuffLen := buffer_size;
            cb.create.notifyProc := gMyNotifyProc;
            cb.create.userDataPtr := Ptr(connection);
            cb.create.localport := localport;
            oe := PBControlSync(@cb);
            localport := cb.create.localport;
            connection^.stream := cb.udpStream;
            connection^.outstanding := 0;
        end;
        if oe <> noErr then begin
            MDisposePtr( connection );
        end;
        UDPCreate := oe;
    end;

    function UDPRead (connection: UDPConnectionPtr; timeout: integer; var remoteIP: longint; var remoteport: integer;
                                    var datap: Ptr; var datalen: integer): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsRead);
        cb.receive.timeout := timeout;
        oe := PBControlSync(@cb);
        if oe = noErr then begin
            connection^.outstanding := connection^.outstanding - 1;
        end;
        remoteIP := cb.receive.remoteip;
        remoteport := cb.receive.remoteport;
        datap := cb.receive.rcvBuff;
        datalen := cb.receive.rcvBuffLen;
        UDPRead := oe;
    end;

    function UDPReturnBuffer (connection: UDPConnectionPtr; datap: Ptr): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsBfrReturn);
        cb.return.rcvBuff := datap;
        oe := PBControlSync(@cb);
        UDPReturnBuffer := oe;
    end;

    function UDPDatagramsAvailable (connection: UDPConnectionPtr): integer;
    begin
        UDPDatagramsAvailable := connection^.outstanding;
    end;

    function UDPWrite (connection: UDPConnectionPtr; remoteIP: longint; remoteport: integer;
                                    datap: Ptr; datalen: integer; checksum: boolean): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
            wds: wdsType;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsWrite);
        cb.send.remoteip := remoteIP;
        cb.send.remoteport := remoteport;
        wds.size := datalen;
        wds.buffer := datap;
        wds.term := 0;
        cb.send.wds := @wds;
        cb.send.checksum := ord(checksum);
        oe := PBControlSync(@cb);
        UDPWrite := oe;
    end;

    function UDPRelease (var connection: UDPConnectionPtr): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsRelease);
        oe := PBControlSync(@cb);
        connection^.magic := UDPBad;
        MDisposePtr(connection);
        UDPRelease := oe;
    end;

    function UDPMTU (remoteIP: longint; var mtu: longint): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, nil, UDPcsMaxMTUSize);
        cb.mtu.remoteip := remoteIP;
        oe := PBControlSync(@cb);
        mtu := BAND(cb.mtu.mtuSize, $FFFF);
        UDPMTU := oe;
    end;

    procedure IPZeroCB (var cb: IPControlBlock; call: integer);
    { Zero out the control block parameters. }
    begin
        MZero(@cb, SizeOf(cb));
        cb.ioCRefNum := mactcp_driver_refnum;
        cb.csCode := call;
    end;

    procedure IPCallCompletion (cbp: IPControlBlockPtr; userdata, extradata: Ptr; addr: UniversalProcPtr);
    begin
        CallPascal0444(cbp,userdata,extradata,addr);
    end;

    procedure IPICMPCompletionPascal (cbp: IPControlBlockPtr);
        var
            index: integer;
    begin
{        DebugStr('IPICMPCompletionPascal'); }
        icmp_got_back := icmp_got_back + 1;
        with cbp^.echoinfo do begin
            index := ord(userDataPtr);
            if (index > 0) & (icmp_data_array[index].complete <> nil) then begin
                IPCallCompletion(cbp, icmp_data_array[index].userdata, icmp_data_array[index].extradata, icmp_data_array[index].complete);
                icmp_data_array[index].complete := nil;
            end;
        end;
    end;

{$IFC GENERATINGPOWERPC}
    procedure IPICMPCompletion(cbp: IPControlBlockPtr);
    begin
        IPICMPCompletionPascal(cbp);
    end;
{$ELSEC}
    procedure IPICMPCompletion;
    begin
        IPICMPCompletionPascal(IPControlBlockPtr(GetStackFrame^.paramblockptr));
    end;
{$ENDC}

    function IPSendICMPEcho (remotehost: ipAddr; timeout: integer; datap: Ptr; datalen: integer; complete: ProcPtr; userdata: univ Ptr; extradata: univ Ptr): OSErr;
        var
            cb: IPControlBlock;
            i, index: integer;
            oe: OSErr;
    begin
{        DebugStr('IPSendICMPEcho');}
        index := -1;
        if complete <> nil then begin
            for i := 1 to max_ICMPDataArray do begin
                if icmp_data_array[i].complete = nil then begin
                    index := i;
                    icmp_data_array[i].complete := complete;
                    icmp_data_array[i].userdata := userdata;
                    icmp_data_array[i].extradata := extradata;
                    leave;
                end;
            end;
        end;
        IPZeroCB(cb, TCPcsEchoICMP);
        cb.echo.dest := remotehost;
        cb.echo.data.buffer := datap;
        cb.echo.data.size := datalen;
        cb.echo.timeout := timeout;
        cb.echo.options := nil;
        cb.echo.optlength := 0;
        cb.echo.icmpCompletion := gIPICMPCompletionProc;
        cb.echo.userDataPtr := Ptr(ord4(index)); { Avoid tickling MW bug }
        oe := PBControlSync(@cb);
        if oe = noErr then begin
            icmp_sent_out := icmp_sent_out + 1;
        end;
        IPSendICMPEcho := oe;
    end;

    function IPGetMyIPAddr (var myIP: ipAddr): OSErr;
        var
            cb: IPControlBlock;
            oe: OSErr;
    begin
        IPZeroCB(cb, TCPcsGetMyIP);
        oe := PBControlSync(@cb);
        myIP := cb.getmyip.ourAddress;
        IPGetMyIPAddr := oe;
    end;

    function InitTCPStuff(var msg: integer): OSStatus;
        var
            err: OSErr;
            i: integer;
    begin
{$unused(msg)}
        msg := ord(SMT_FailedToInitTCP);
        gTCPPreCompletionProc := NewProc(@TCPPreCompletion, uppC04ProcInfo);
        gDoIOCompletionProc := NewProc(@DoIOCompletion, uppC04ProcInfo);
        gIPICMPCompletionProc := NewProc(@IPICMPCompletion, uppC04ProcInfo);
        gTCPSendCompleteProc := NewProc(@TCPSendComplete,uppPascal04ProcInfo);
        gMyNotifyProc := NewProc(@MyNotify,uppPascal04244ProcInfo);
        err := OpenDriver('.IPP', mactcp_driver_refnum);
        for i := 1 to control_block_max do begin
            controlblocks[i] := nil;
        end;
        icmp_sent_out := 0;
        icmp_got_back := 0;
        for i := 1 to max_ICMPDataArray do begin
            icmp_data_array[i].complete := nil;
        end;
        largest_mtu := 576;
        largest_minimum_tcp_buffer_size := 4096;
{
        if err = noErr then begin
            junkl := GetMinimumBufferSize(0, true);
        end;
}
        InitTCPStuff := err;
    end;

    procedure FinishTCPStuff;
        var
            i: integer;
    begin
        for i := 1 to control_block_max do begin
            if controlblocks[i] <> nil then begin
                MDisposePtr(controlblocks[i]);
            end;
        end;
    end;

    procedure StartupTCPStuff;
    begin
        StartupTCPUtils;
        SetStartup( InitTCPStuff, nil, 0, FinishTCPStuff );
    end;

end.