MacGames Sampler/PHT MacGames Bundle.iso/MacSource Folder/Samples from the CD/Pascal/Source□/Talk Source/Talk ƒ/Talks.p

Text File | 1992-04-20 | 16.0 KB | 665 lines | [TEXT/PJMM]

unit Talks;

{ This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }

interface

    uses
        OOStatus;

    procedure InitTalks;
    procedure FinishTalks;
    procedure HandleStatusCommand (data: longInt; sc: statusCommands; var s: string);
    procedure HandleEvents;

    const
        max_notify_display_time = longInt(1) * 60 * 60;

implementation

    uses
        OOMainLoop, AppGlobals, Preferences, MyNotifier, MyInternetMenu, MyTranslate82728,{}
        TCPTypes, TCPStuff, TCPConnections, OOTalk, TalkUtils, TalkUDPPackets,{}
        PrefsGlobals, MyUtils, MyUtilities;

    type
        MyTalkObject = object(TalkObject)
                tcpc: TCPConnectionPtr;
                mtc: MyTalkConnection;
                procedure TransmitKey (ch: char);
                override;
                procedure TransmitBlock (h: handle; len: longInt);
                override;
                procedure Destroy;
                override;
            end;
        BaseTalkConnection = object
                procedure HandleEvent (cer: connectionEventRecord);
                procedure HandleStatusCommand (sc: statusCommands; var s: string);
                procedure GotResponse (var request, response: ctlMsg);
            end;
        DaemonTalkConnection = object(BaseTalkConnection)
                procedure Create;
                procedure Destroy;
                procedure GotResponse (var request, response: ctlMsg);
                override;
            end;
        MyTalkConnection = object(BaseTalkConnection)
                local_id, remote_id: longInt;
                mto: MyTalkObject;
                title: stringHandle;
                packet_state: (PS_None, PS_Verifying, PS_Connecting);
                lastresponse: ctlMsg;
                machname: str63;
                ourcontrolport: integer;
                ourtcpport: integer;
                remotecontrolhost: longInt;
                con: connectionIndex;
                waitingforeditchars: boolean;
                delchar: char;
                procedure Create;
                procedure Destroy;
                procedure SelfDestruct;
                procedure StartConnect (s: str255);
                procedure InitiateConnect (remoteIP: longInt);
                procedure DeletePackets;
                procedure PartialClose;
                procedure SendCloseMessage;
                procedure HandleEvent (cer: connectionEventRecord);
                override;
                procedure GotResponse (var request, response: ctlMsg);
                override;
                procedure HandleStatusCommand (sc: statusCommands; var s: string);
                override;
            end;
{ HandleEvent(closed) -> Destroy mto }
{ Window Close -> Destroy mto }
{ Destroy mto -> Destroy mtc }

    var
        daemon: DaemonTalkConnection;
        trans_in, trans_out: transTable;

    procedure InitTalks;
        var
            oe: OSErr;
    begin
        GetTrans(translateOutResID, trans_out);
        GetTrans(translateInResID, trans_in);
        oe := InitUDPPackets;
        new(daemon);
        daemon.Create;
    end;

    procedure FinishTalks;
    begin
        daemon.Destroy;
        FinishUDPPackets;
    end;

    procedure BaseTalkConnection.HandleStatusCommand (sc: statusCommands; var s: string);
    begin
        SysBeep(1);
    end;

    procedure BaseTalkConnection.GotResponse (var request, response: ctlMsg);
    begin
        SysBeep(1);
    end;

    procedure BaseTalkConnection.HandleEvent (cer: connectionEventRecord);
    begin
        SysBeep(1);
    end;

    procedure SetupMessage (var m: ctlMsg);
    begin
        m.vers := talk_version;
        m.id_num := -1;
        m.addr.family := AF_INET;
        m.addr.ip := my_machine_addr;
        m.addr.port := 0;
        m.ctl_addr.family := AF_INET;
        m.ctl_addr.ip := my_machine_addr;
        m.ctl_addr.port := 0;
    end;

    procedure DaemonTalkConnection.Create;
        var
            m: ctlMsg;
    begin
        SetupMessage(m);
        if CreateUDPChannel(self, -1, m.ctl_addr.port) = noErr then begin
            m.typ := CT_Scan;
            m.id_num := 1;
            SendPacket(self, WT_Soon, m, my_machine_addr, talkd_port);
        end;
    end;

    procedure DaemonTalkConnection.Destroy;
    begin
        DestroyUDPChannel(self);
    end;

    procedure MyTalkConnection.GotResponse (var request, response: ctlMsg);
        var
            cp: connectionIndex;
            state, localport, remoteport: integer;
            localhost, remotehost, available: longInt;
            tcpc: TCPConnectionPtr;
            a: integer;
    begin
        case request.typ of
            CT_VerifyAnnounce:  begin
                if response.answer = a_success then
                    SendPacket(self, WT_Delayed, request, my_machine_addr, talkd_port)
                else
                    SelfDestruct;
            end;
            CT_LookUp:  begin
                if response.answer = a_success then begin
                    remote_id := response.id_num;
                    if NewActiveConnection(cp, Default_TCPBUFFERSIZE, response.addr.ip, response.addr.port, self) <> noErr then begin
                        SelfDestruct;
                        SysBeep(1);
                    end
                    else begin
                        con := cp;
                    end;
                end
                else if NewPassiveConnection(cp, Default_TCPBUFFERSIZE, 0, 0, 0, self) <> noErr then begin
                    SelfDestruct;
                    SysBeep(1);
                end
                else begin
                    con := cp;
                    GetConnectionTCPC(cp, tcpc);
                    repeat
                        TCPRawState(tcpc, state, localhost, localport, remotehost, remoteport, available);
                    until (localport <> 0) or (TCPState(tcpc) = T_Closed);
                    ourtcpport := localport;
                    request.addr.port := localport;
                    request.typ := CT_leave_invite;
                    SendPacket(self, WT_Soon, request, my_machine_addr, talkd_port);
                end;
            end;
            CT_leave_invite:  begin
                if response.answer = a_success then begin
                    local_id := response.id_num;
                    request.typ := CT_Announce;
                    SendPacket(self, WT_Soon, request, remotecontrolhost, talkd_port);
                end
                else if response.answer = a_permission_denied then begin
                    Paramtext(title^^, '', '', '');
                    a := Alert(PermDeniedAlertID, nil);
                    SelfDestruct;
                end
                else begin
                    Paramtext(title^^, '', '', '');
                    a := Alert(RefusedAlertID, nil);
                    SelfDestruct;
                end;
            end;
            CT_Announce:  begin
                if response.answer = a_success then begin
                    remote_id := response.id_num;
                    SetEntry(self, rd_whatever, rs_connecting, '');
{Hmm, no more packets needed I guess}
                end
                else
                    SelfDestruct;
            end;
            otherwise
                ;
        end;
    end;

    procedure DaemonTalkConnection.GotResponse (var request, response: ctlMsg);
        var
            mtc: MyTalkConnection;
            title: str255;
            sh: stringHandle;
            m: ctlMsg;
            cp: connectionIndex;
            when: whenType;
    begin
        when := WT_Delayed;
        if response.answer = a_success then begin
            if not FindRequest(response.id_num, mtc) then begin
                new(mtc);
                mtc.Create;
                mtc.local_id := response.id_num;
                mtc.con := no_connection;
                mtc.packet_state := PS_Verifying;
                mtc.lastresponse := response;
                mtc.remotecontrolhost := response.ctl_addr.ip;
                if FindName(cp, response.ctl_addr.ip, mtc) <> noErr then begin
                    FindString(response.ctl_addr.ip, title);
                    mtc.StartConnect(title);
                end;
                when := WT_Soon;
            end;
            request.id_num := request.id_num + 1
        end
        else
            request.id_num := 1;
        SendPacket(self, when, request, my_machine_addr, talkd_port);
    end;

    procedure HandleStatusCommand (data: longInt; sc: statusCommands; var s: string);
    begin
        if data <> 0 then
            BaseTalkConnection(data).HandleStatusCommand(sc, s);
    end;

{$Z+}
    procedure TalkTo (s: str255);
        var
            mtc: MyTalkConnection;
            name, mach: str255;
            sh: stringHandle;
            oe: OSErr;
            cp: connectionIndex;
    begin
        UnPackName(s, name, mach);
        new(mtc);
        mtc.Create;
        mtc.con := no_connection;
        mtc.packet_state := PS_Connecting;
        mtc.lastresponse.l_name := PStrToUser(name);
        mtc.machname := mach;
        sh := NewString(s);
        mtc.title := sh;
        SetEntry(mtc, rd_outgoing, rs_request, s);
        oe := FindAddress(cp, mach, mtc);
        if oe <> noErr then begin
            FailAlert('FindAddress failed with', oe);
        end;
    end;
{$Z-}

    procedure MyTalkConnection.Create;
        var
            sh: stringHandle;
    begin
        mto := nil;
        title := nil;
        packet_state := PS_None;
        local_id := -1;
        remote_id := -1;
    end;

    procedure MyTalkConnection.PartialClose;
    begin
        if con <> no_connection then begin
            CloseConnection(con);
            SetDataPtr(con, nil);  { ignore all future events }
            con := no_connection;
            if mto <> nil then
                mto.tcpc := nil;
        end;
    end;

    procedure MyTalkConnection.SendCloseMessage;
        var
            s: str255;
            i: integer;
    begin
        s := concat(cr, '[Connection Closed]', cr);
        for i := 1 to length(s) do
            mto.ReceiveKey(s[i]);
    end;

    procedure MyTalkConnection.Destroy;
    begin
        if title <> nil then
            DisposHandle(handle(title));
        RemoveEntry(self);
        PartialClose;
        DeletePackets;
        DestroyUDPChannel(self);
        dispose(self);
    end;

    procedure MyTalkConnection.SelfDestruct;
    begin
        if mto = nil then
            Destroy
        else
            mto.Destroy;
    end;

    procedure MyTalkObject.Destroy;
    begin
        if mtc <> nil then
            mtc.Destroy;
        inherited Destroy;
    end;

    function TranslateChar (ch: char): char;
    begin
        case ch of
            cr:
                ch := lf;
            bs:
                ch := del;
            otherwise
                ;
        end;
        TranslateChar := chr(BAND(trans_out[ord(ch)], $FF));
    end;

    procedure MyTalkObject.TransmitKey (ch: char);
        var
            s: string[1];
            oe: OSErr;
    begin
        if tcpc <> nil then begin
            s := TranslateChar(ch);
            oe := TCPSendAsync(tcpc, @s[1], 1, nil);
        end;
    end;

    procedure MyTalkObject.TransmitBlock (h: handle; len: longInt);
        var
            buffer: buf255;
            l, i: integer;
            pos: longInt;
            oe: OSErr;
    begin
        pos := 0;
        while len > 0 do begin
            l := SizeOf(buffer);
            if l > len then
                l := len;
            BlockMove(ptr(longInt(h^) + pos), @buffer, l);
            for i := 0 to l - 1 do
                buffer[i] := TranslateChar(buffer[i]);
            oe := TCPSendAsync(tcpc, @buffer, l, nil);
            pos := pos + l;
            len := len - l;
        end;
    end;

    procedure MyTalkConnection.HandleStatusCommand (sc: statusCommands; var s: string);
        var
            m: ctlMsg;
            tname: userStr;
    begin
        case sc of
            SC_Abort:  begin
                if mto <> nil then begin
                    SetEntry(self, rd_whatever, rs_disconnected, '');
                    PartialClose;
                    SendCloseMessage;
                end
                else begin
                    SetEntry(self, rd_whatever, rs_failed, '');
                    SelfDestruct;
                end;
            end;
            SC_Connect:  begin
                if packet_state = PS_Verifying then begin
                    SetEntry(self, rd_whatever, rs_connecting, '');
                    packet_state := PS_Connecting;
                    m := lastresponse;
                    SetupMessage(m);
                    m.typ := CT_LookUp;
                    m.ctl_addr.port := ourcontrolport;
                    m.id_num := 0;
                    tname := m.l_name;
                    m.l_name := m.r_name;
                    m.r_name := tname;
                    SendPacket(self, WT_Soon, m, lastresponse.ctl_addr.ip, talkd_port);
                end
                else if packet_state = PS_Connecting then begin
                    SetEntry(self, rd_whatever, rs_request, '');
                    m := lastresponse;
                    SetupMessage(m);
                    m.typ := CT_Announce;
                    m.ctl_addr.port := ourcontrolport;
                    m.addr.port := ourtcpport;
                    m.id_num := remote_id + 1;
                    m.r_name := lastresponse.l_name;
                    m.r_tty[1] := nul;
                    m.l_name := PStrToUser(GetMyUserName(prefs));
                    SendPacket(self, WT_Soon, m, remotecontrolhost, talkd_port);
                end
            end;
            SC_BringToFront:
                if mto <> nil then
                    SelectWindow(mto.us.window);
            otherwise
                ;
        end;
    end;

    procedure DoNotify (s: str255; user: str31);
        const
            sicn_size = 32;
        var
            sicnH, nmSicn, snd: handle;
            sh: stringPtr;
            time: str255;
            secs: longInt;
    begin
        if prefs.allowconnect <> AC_Never then
            if not in_foreground then begin
                if prefs.notify_flash then begin
                    nmSicn := NewHandle(sicn_size);
                    sicnH := GetResource('SICN', sicn_id);
                    if (sicnH <> nil) and (nmSicn <> nil) then
                        BlockMove(sicnH^, nmSicn^, sicn_size)
                    else if nmSicn <> nil then begin
                        DisposHandle(nmSicn);
                        nmSicn := nil;
                    end;
                    HPurge(sicnH);
                end
                else
                    nmSicn := nil;
                if prefs.notify_beep then
                    snd := handle(-1)
                else
                    snd := nil;
                if prefs.notify_alert then begin
                    GetDateTime(secs);
                    IUTimeString(secs, false, time);
                    SPrintS5(s, GetGlobalString(notify_str), s, user, time, '', '');
                    sh := stringPtr(NewPtr(length(s) + 1));
                    sh^ := s;
                end
                else
                    sh := nil;
                NotifyH(mark_app, snd, nmSicn, sh, max_notify_display_time);
            end
            else if prefs.notify_beep then
                SysBeep(3);
    end;

    procedure MyTalkConnection.StartConnect (s: str255);
        var
            sh: stringHandle;
            m: ctlMsg;
    begin
        PackName(s, UserToPStr(lastresponse.l_name), s);
        sh := NewString(s);
        title := sh;
        SetEntry(self, rd_incoming, rs_request, s);
        if prefs.show_status then
            ShowStatus;
        m := lastresponse;
        SetupMessage(m);
        DoNotify(s, m.l_name);
        if CreateUDPChannel(self, lastresponse.id_num, m.ctl_addr.port) = noErr then begin
            ourcontrolport := m.ctl_addr.port;
            m.typ := CT_VerifyAnnounce;
            m.id_num := lastresponse.id_num;
            SendPacket(self, WT_Soon, m, my_machine_addr, talkd_port);
        end;
    end;

    procedure MyTalkConnection.InitiateConnect (remoteIP: longInt);
        var
            m: ctlMsg;
            i: integer;
            oe: OSErr;
    begin
        remotecontrolhost := remoteIP;
        SetupMessage(m);
        oe := CreateUDPChannel(self, lastresponse.id_num, m.ctl_addr.port);
        if oe = noErr then begin
            ourcontrolport := m.ctl_addr.port;
            m.typ := CT_LookUp;
            m.id_num := -1;
            m.r_name := lastresponse.l_name;
            m.l_name := PStrToUser(GetMyUserName(prefs));
            m.r_tty[1] := nul;
            SendPacket(self, WT_Soon, m, remoteIP, talkd_port);
        end
        else
            FailAlert('Failed to open UDP Channel (cryptic error ain''t it?)', oe);
    end;

    procedure MyTalkConnection.DeletePackets;
        var
            m: ctlMsg;
    begin
        SetupMessage(m);
        m.typ := CT_Delete;
        m.ctl_addr.port := ourcontrolport;
        if local_id <> -1 then begin
            m.id_num := local_id;
            local_id := -1;
            SendOnePacket(m, my_machine_addr, talkd_port);
        end;
        if remote_id <> -1 then begin
            m.id_num := remote_id;
            remote_id := -1;
            SendOnePacket(m, remotecontrolhost, talkd_port);
        end;
    end;

    procedure DebugChar (dc, ch: char);
    begin
{ Delete this routine! It does nothing, its for debugging the values of delchar and ch }
        dc := ch;
    end;

    procedure MyTalkConnection.HandleEvent (cer: connectionEventRecord);
        var
            tmto: MyTalkObject;
            s: str255;
            oe: OSErr;
            i: integer;
            ch: char;
    begin
        with cer do
            case event of
                C_Found:  begin
                    InitiateConnect(value);
                end;
                C_SearchFailed:  begin
                    FailAlert(concat('Unknown machine "', machname, '"'), 0);
                    SelfDestruct;
                end;
                C_NameFound:  begin
                    StartConnect(stringHandle(value)^^);
                    DisposHandle(handle(value));
                end;
                C_NameSearchFailed:  begin
                    FindString(lastresponse.ctl_addr.ip, s);
                    StartConnect(s);
                end;
                C_FailedToOpen:  begin
                    if timedout then
                        FailAlert(concat('Timed out connecting to ', title^^), 0)
                    else
                        FailAlert(concat('Machine "', title^^, '" doesn''t answer'), 0);
                    SetEntry(self, rd_whatever, rs_failed, '');
                    con := no_connection;
                    SelfDestruct;
                end;
                C_Established:  begin
                    new(tmto);
                    mto := tmto; { don't you hate handles? }
                    mto.mtc := self;
                    mto.Create(talk_output_dialog_id);
                    delchar := del;
                    s := title^^;
                    AddInternetCommand(title^^);
                    SetWTitle(mto.us.window, s);
                    SetEntry(self, rd_whatever, rs_connected, title^^);
                    ShowWindow(mto.us.window);
                    mto.tcpc := tcpc;
                    waitingforeditchars := true;
{ Send three edit chars, whatever they might be... }
                    s := concat(del, chr($15), chr($17));
                    oe := TCPSendAsync(tcpc, @s[1], length(s), nil);
                    DeletePackets;
                end;
                C_CharsAvailable:  begin
                    if waitingforeditchars then begin
{$PUSH}
{$R-}
                        if value >= 3 then begin
                            waitingforeditchars := false;
                            oe := TCPReceiveChars(tcpc, @s[1], 3);
                            delchar := s[1];
                        end;
                    end
                    else begin
                        if value > 255 then
                            value := 255;
                        oe := TCPReceiveChars(tcpc, @s[1], value);
                        if oe = noErr then
                            for i := 1 to value do begin
                                DebugChar(delchar, s[i]);
                                if s[i] = delchar then begin
                                    mto.ReceiveKey(del);
                                end
                                else begin
                                    ch := chr(trans_in[ord(s[i])]);
                                    if ch = del then
                                        mto.ReceiveKey(spc)
                                    else if ch = bs then begin
                                        mto.ReceiveKey('^');
                                        mto.ReceiveKey('H');
                                    end
                                    else
                                        mto.ReceiveKey(ch);
                                end;
                            end;
{$R+}
                    end;
                end;
                C_Closing:  begin
                    SetEntry(self, rd_whatever, rs_disconnected, '');
                    PartialClose;
                    SendCloseMessage;
                end;
                C_Closed:  begin
                    SetEntry(self, rd_whatever, rs_failed, '');
                    PartialClose;
                    SendCloseMessage;
                end;
                otherwise
                    ;
            end;{case}
    end;

    procedure HandleEvents;
        var
            btc: BaseTalkConnection;
            cer: connectionEventRecord;
        var
            request, response: ctlMsg;
    begin
        if ReceivePacket(btc, request, response) then
            btc.GotResponse(request, response);
        if GetConnectionEvent(any_connection, cer) then
            if cer.dataptr <> nil then
                BaseTalkConnection(cer.dataptr).HandleEvent(cer);
    end;

end.