Info-Mac 1992 August/info-mac-1992.iso/Source/Pascal/Chat/Chat 1.0.0 Source/Chat.p

Text File | 1992-04-26 | 8.3 KB | 351 lines | [TEXT/PJMM]

{$I-}
program Chat;

{ This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
{ You may use this source in your own free/shareware projects as long as you acknowledge me }
{ in your About box and documentation files.  You may include it in commercial products }
{ only if I explicitly allow it. }

    uses
        TCPStuff, TCPConnections, MyTypes, MyLists, MyStripTelnetCodes;

    const
        globalStrhResID = 128;

    type
        strings = (noIndex, portIndex, irclogname, irclogtype, quitnowIndex, quitIndex, listIndex, {}
            howdullIndex, startingupatIndex, welcomeIndex,{}
            loggedinatIndex, youneedanameIndex, nameinuseIndex, welcome2index, hasenteredIndex, {}
            closingdownIndex, closingdownatIndex, byebyeIndex, colonIndex, hasleftIndex);

    type
        infoRecord = record
                cp: connectionIndex;
                state: (S_unconnected, S_GettingName, S_GettingPassword, S_Connected, S_Closed);
                buffer: str255;
                name: str31;
                wason: boolean;
            end;
        infoPtr = ^infoRecord;

    var
        lh: listHead;
        quitNow: boolean;
        logrn: integer;
        connected: integer;
        port: integer;
        dolog: boolean;

    function GetGlobalString (n: strings): str255;
        var
            s: str255;
    begin
        GetIndString(s, globalStrhResID, ord(n));
        GetGlobalString := s;
    end;

    procedure CreatePC;
        var
            p: infoPtr;
            oe: OSErr;
    begin
        p := infoPtr(Newptr(SizeOf(infoRecord)));
        p^.state := S_unconnected;
        p^.wason := false;
        oe := NewPassiveConnection(p^.cp, Minimum_TCPBUFFERSIZE, port, 0, 0, p);
        AddTail(lh, p);
    end;

    procedure DestroyPC (p: infoPtr);
        var
            item: listItem;
            lp: infoPtr;
    begin
        if FindItem(lh, p, item) then begin
            DisposPtr(ptr(p));
            DeleteItem(item, p);
        end;
    end;

    function GetLine (tcpc: TCPConnectionPtr; value: longInt; var buffer: str255): boolean;
        var
            len: longInt;
            gotlf: boolean;
            i, j: integer;
    begin
        GetLine := false;
        len := length(buffer);
{$PUSH}
{$R-}
        if TCPReceiveUpTo(tcpc, 10, 1, @buffer[1], SizeOf(buffer) - 1, len, gotlf) = noErr then begin
            i := 1;
            j := 1;
            while (i <= len) do begin
                case buffer[i] of
                    cr, lf:
                        i := i + 1;
                    bs, del:  begin
                        i := i + 1;
                        if j > 1 then
                            j := j - 1;
                    end;
                    otherwise begin
                        buffer[j] := buffer[i];
                        i := i + 1;
                        j := j + 1;
                    end;
                end;
            end;
            buffer[0] := chr(j - 1);
            GetLine := gotlf;
        end;
{$POP}
    end;

    procedure SendString (tcpc: TCPCOnnectionPtr; s: str255);
        var
            oe: OSErr;
    begin
{$PUSH}
{$R-}
        oe := TCPSendAsync(tcpc, @s[1], length(s), nil);
{$POP}
    end;

    procedure StartLog;
        var
            oe: OSErr;
    begin
        if dolog then begin
            oe := HCreate(-1, 2, GetGlobalString(irclogname), GetGlobalString(irclogtype), 'TEXT');
            oe := HOpen(-1, 2, GetGlobalString(irclogname), fsWrPerm, logrn);
            oe := SetFPos(logrn, fsFromLEOF, 0);
        end;
    end;

    procedure StopLog;
        var
            oe: OSErr;
    begin
        if dolog then begin
            oe := FSClose(logrn);
        end;
    end;

    procedure Log (s: str255);
        var
            count: longInt;
            oe: OSErr;
    begin
        if dolog then begin
            if s[length(s)] = lf then
                s := copy(s, 1, length(s) - 1);
            count := length(s);
{$PUSH}
{$R-}
            oe := FSWrite(logrn, count, @s[1]);
{$POP}
        end;
    end;

    procedure SendExceptString (p: infoPtr; s: str255);
        var
            item: listItem;
            lp: infoPtr;
            tcpc: TCPConnectionPtr;
    begin
        Log(s);
        ReturnHead(lh, item);
        while not IsTail(item) do begin
            Fetch(item, lp);
            if (lp <> p) and (lp^.state = S_connected) then begin
                GetConnectionTCPC(lp^.cp, tcpc);
                SendString(tcpc, s);
            end;
            MoveToNext(item);
        end;
    end;

    function NameInUse (p: infoPtr): boolean;
        var
            item: listItem;
            lp: infoPtr;
            tcpc: TCPConnectionPtr;
    begin
        NameInUse := false;
        ReturnHead(lh, item);
        while not IsTail(item) do begin
            Fetch(item, lp);
            if (lp <> p) and (lp^.state = S_connected) then begin
                if IUEqualString(lp^.name, p^.name) = 0 then begin
                    NameInUse := true;
                    leave;
                end;
            end;
            MoveToNext(item);
        end;
    end;

    procedure SendExceptNames (tcpc: TCPCOnnectionPtr; p: infoPtr);
        var
            item: listItem;
            lp: infoPtr;
            first: boolean;
            len: integer;
    begin
        first := true;
        len := 0;
        ReturnHead(lh, item);
        while not IsTail(item) do begin
            Fetch(item, lp);
            if (lp <> p) and (lp^.state = S_connected) then begin
                if first then
                    first := false
                else begin
                    SendString(tcpc, ', ');
                    len := len + 2;
                end;
                if len + length(lp^.name) > 75 then begin
                    SendString(tcpc, concat(cr, lf));
                    len := 0;
                end;
                SendString(tcpc, lp^.name);
                len := len + length(lp^.name);
            end;
            MoveToNext(item);
        end;
        if first then
            SendString(tcpc, concat(GetGlobalString(howdullIndex), cr, lf))
        else
            SendString(tcpc, concat(cr, lf));
    end;

    function GetTimeStr: str255;
        var
            st, sd: str255;
            date: longInt;
    begin
        GetDateTime(date);
        IUDateString(date, abbrevDate, sd);
        IUTimeString(date, false, st);
        GetTimeStr := concat(st, ', ', sd);
    end;

    procedure WNE;
        var
            dummy: boolean;
            er: eventRecord;
    begin
        dummy := WaitNextEvent(everyEvent, er, 15, nil);
    end;

    function StackPtr: longInt;
    inline
        $2E8F;

    var
        cer: connectionEventRecord;
        p: infoPtr;
        oe: OSErr;
        dummylong: longInt;
begin
    SetApplLimit(ptr(StackPtr - 10000));
    MaxApplZone;
    MoreMasters;
    StringToNum(GetGlobalString(portIndex), dummylong);
    port := dummylong;
    dolog := GetGlobalString(irclogname) <> '';
    if InitConnections('') = noErr then begin
        StartLog;
        Log(concat(GetGlobalString(startingupatIndex), GetTimeStr, cr, lf));
        StopLog;
        CreateList(lh);
        CreatePC;
        CreatePC;
        connected := 0;
        while not quitNow do begin
            WNE;
            if GetConnectionEvent(any_connection, cer) then
                with cer do begin
                    p := infoPtr(dataptr);
                    with p^ do
                        case event of
                            C_Established:  begin
                                if connected = 0 then
                                    StartLog;
                                connected := connected + 1;
                                state := S_GettingName;
                                buffer := '';
                                SendString(tcpc, GetGlobalString(welcomeIndex));
                                CreatePC;
                            end;
                            C_CharsAvailable:  begin
                                if GetLine(tcpc, value, buffer) then begin
                                    StripTelnetCodes(buffer);
                                    case state of
                                        S_GettingName:  begin
                                            Log(concat(buffer, GetGlobalString(loggedinatIndex), GetTimeStr, cr, lf));
                                            name := buffer;
                                            state := S_connected;
                                            if buffer = '' then begin
                                                SendString(tcpc, concat(GetGlobalString(youneedanameIndex), cr, lf));
                                                state := S_Closed;
                                                CloseConnection(connection);
                                            end
                                            else if NameInUse(p) then begin
                                                SendString(tcpc, concat(GetGlobalString(nameinuseIndex), cr, lf));
                                                state := S_Closed;
                                                CloseConnection(connection);
                                            end
                                            else begin
                                                buffer := '';
                                                SendString(tcpc, GetGlobalString(welcome2index));
                                                SendExceptNames(tcpc, p);
                                                SendExceptString(p, concat(name, GetGlobalString(hasenteredIndex), cr, lf));
                                                wason := true;
                                            end;
                                        end;
                                        S_GettingPassword:  begin
                                        end;
                                        S_Connected:  begin
                                            if buffer = GetGlobalString(quitnowIndex) then begin
                                                quitNow := true;
                                                SendString(tcpc, concat(GetGlobalString(closingdownIndex), cr, lf));
                                                SendExceptString(p, concat(GetGlobalString(closingdownatIndex), GetTimeStr, cr, lf));
                                            end
                                            else if IUEqualString(buffer, GetGlobalString(quitIndex)) = 0 then begin
                                                SendString(tcpc, concat(GetGlobalString(byebyeIndex), cr, lf));
                                                state := S_Closed;
                                                CloseConnection(connection);
                                            end
                                            else if IUEqualString(buffer, GetGlobalString(listIndex)) = 0 then begin
                                                SendExceptNames(tcpc, p);
                                            end
                                            else
                                                SendExceptString(p, concat(name, GetGlobalString(colonIndex), buffer, cr, lf));
                                            buffer := '';
                                        end;
                                        otherwise
                                            ;
                                    end;
                                end;
                            end;
                            C_Closing:  begin
                                state := S_Closed;
                                CloseConnection(connection);
                            end;
                            C_Closed:  begin
                                if wason then
                                    SendExceptString(p, concat(name, GetGlobalString(hasleftIndex), cr, lf));
                                connected := connected - 1;
                                DestroyPC(p);
                                if connected = 0 then
                                    StopLog;
                            end;
                        end;
                end;
        end;
        StopLog;
        FinishEverything;
    end;
end.