Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Main.pas

01.01.2007
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        alexander_vaga@hotmail.com
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine
 
              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.
 
              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{$A-,B+,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M+,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
unit Main;
interface
uses
  Windows, Messages, SysUtils, Graphics,
  Forms, Dialogs, ComCtrls, Buttons, ToolWin,
  ExtCtrls, Menus, ImgList, ScktComp, Controls,
  StdCtrls, Classes, inifiles,
  Types, Packet;
 
type
  TForm1 = class(TForm)
    MainT: TTimer;
    StatusMenu: TPopupMenu;
    OnlineConnected1: TMenuItem;
    FreeForChat1: TMenuItem;
    sep1: TMenuItem;
    Away1: TMenuItem;
    NAExtendedAway1: TMenuItem;
    sep2: TMenuItem;
    OccupiedUrgentMsgs1: TMenuItem;
    DNDDoNotDisturb1: TMenuItem;
    sep3: TMenuItem;
    PrivacyInvisible1: TMenuItem;
    OfflineDiscconnect1: TMenuItem;
    Panel1: TPanel;
    Panel3: TPanel;
    Splitter1: TSplitter;
    CLI: TClientSocket;
    BG: TPanel;
    Memo: TMemo;
    StatusBtn: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure InitUser;
    procedure InitLogs;
    procedure CloseLogs;
    procedure ConnectMode(Mode : boolean);
    procedure MainTTimer(Sender: TObject);
    procedure OnlineConnected1Click(Sender: TObject);
    procedure Away1Click(Sender: TObject);
    procedure DNDDoNotDisturb1Click(Sender: TObject);
    procedure PrivacyInvisible1Click(Sender: TObject);
    procedure OfflineDiscconnect1Click(Sender: TObject);
    procedure OccupiedUrgentMsgs1Click(Sender: TObject);
    procedure FreeForChat1Click(Sender: TObject);
    procedure NAExtendedAway1Click(Sender: TObject);
    procedure CLIConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure CLI_ReadData(Sender: TObject; Socket: TCustomWinSocket);
    procedure CLIDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure PacketSend(p:PPack);
    procedure ShowUserONStatus(p:PPack);
    procedure SNAC_15_3(p:PPack);
    procedure SNAC_4_7(p:PPack);
    procedure icq_Login(Status : longint);
    procedure SetStatus(Status:longint);
    procedure StatusChange(Status:longint);
    procedure AuthorizePart(p:PPack);
    procedure WorkPart(p:PPack);
    procedure DoMsg(on_off:boolean;typemes,lenmes:integer; data:PCharArray; r_uin:longint; DateTime:TDateTime);
    procedure DoSimpleMsg(r_uin:longint; Text:string);
    procedure ClearFIFO;
    procedure debugFILE(tmp:PPack; Direction:char);
    procedure LogMessage(s:string);
    procedure StatusBtnClick(Sender: TObject);
  private{ Private declarations }
  public { Public declarations }
  protected { Protected declarations }
  published { Published declarations }
 end;
 
var Form1 : TForm1;
    UIN           : longint;
    NICK          : string;
    PASSWORD      : string;
    ICQStatus     : longint;
    DIM_IP        : IPArray;
    Local_IP      : string;
    Local_Name    : string;
    SEQ           : word;
    FLAP          : FLAP_HDR;
    FLAP_DATA     : TByteArray;
    Index         : integer;
    NeedBytes     : integer;
    sCOOKIE       : string;
    Cookie        : word;
    WorkAddress   : string;
    WorkPort      : integer;
    log,mess      : text;
 
const
    isLogged   : boolean = false;
    isAuth     : boolean = true;
    isHDR      : boolean = true;
    HeadFIFO   : PFLAP_Item = nil;
 
implementation
 
{$R *.DFM}
 
(****************************************************************)
procedure TForm1.PacketSend(p:PPack);
begin
       SetLengthPacket(p);
       CLI.socket.sendbuf(p^.data,p^.length);
       debugFILE(p,'>');
       PacketDelete(p);
end;
 
(****************************************************************)
procedure TForm1.ConnectMode(Mode : boolean);
begin
     case Mode of
      true: begin
        isLogged := true;
        case ICQStatus of
          STATE_ONLINE:      StatusBtn.Caption := 'online';
          STATE_AWAY:        StatusBtn.Caption := 'away';
          STATE_DND:         StatusBtn.Caption := 'dnd';
          STATE_OCCUPIED:    StatusBtn.Caption := 'occupied';
          STATE_FREEFORCHAT: StatusBtn.Caption := 'freeforchat';
          STATE_N_A:         StatusBtn.Caption := 'na';
          STATE_INVISIBLE:   StatusBtn.Caption := 'invisible';
          else               StatusBtn.Caption := 'offline';
        end;
      end;
      false: begin
        If CLI.Active then CLI.Close;
        ClearFIFO;
        isLogged := false;
        StatusBtn.Caption := 'offline';
      end;
     end; 
end;
 
(****************************************************************)
procedure TForm1.FormCreate(Sender: TObject);
begin
    InitUser;
    InitLogs;
end;
 
(****************************************************************)
procedure TForm1.debugFILE(tmp:PPack; Direction:char);
begin
     writeln(log,DateTimeToStr(Now)+' =================================');
     writeln(log,Direction+'FLAP: '+inttohex(tmp^.Sign,2)+' '+
          inttohex(tmp^.ChID,2)+' '+inttohex(swap(tmp^.SEQ),4)+' '+
          inttohex(swap(tmp^.Len),4)+' '+'['+inttostr(swap(tmp^.Len))+']');
     writeln(log,Direction+'SNACK:  $'+inttohex(swap(tmp^.SNAC.FamilyID),4)+
                     ':'+inttohex(swap(tmp^.SNAC.SubTypeID),4)+
              ' flags:$'+inttohex(swap(word(tmp^.SNAC.Flags)),4)+
                ' ref:$'+inttohex(DSwap(tmp^.SNAC.RequestID),8));
     writeln(log,Dim2Str(@(tmp^.FLAP_BODY),swap(tmp^.FLAP.Len)));
     writeln(log,Dim2Hex(@(tmp^.FLAP_BODY),swap(tmp^.FLAP.Len)));
     writeln(log,'');
end;
 
(****************************************************************)
procedure TForm1.CLIDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
     M(Memo,'Disconnected: '+Socket.RemoteAddress);
end;
 
(****************************************************************)
procedure TForm1.CLIConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
     M(Memo,'Connected: '+Socket.RemoteAddress);
end;
 
(****************************************************************)
procedure TForm1.CLI_ReadData(Sender: TObject; Socket: TCustomWinSocket);
var num,Bytes,fact : integer;
    pFIFO,CurrFIFO : PFLAP_Item;
    buf : array[0..100] of byte;
begin
     num := Socket.ReceiveLength;
     if isHDR then begin
       if num>=6 then begin
         Socket.ReceiveBuf(FLAP,6);
         NeedBytes := swap(FLAP.Len);
         Index := 0;
         isHDR := not isHDR;
       end else begin
             M(memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
             Socket.ReceiveBuf(buf,num);
             M(Memo,Dim2Hex(@(buf),num));
             M(memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
           end;
 
     end else begin  
         Bytes := NeedBytes;
         fact := Socket.ReceiveBuf(FLAP_DATA[Index],Bytes);
         inc(Index,fact);
         dec(NeedBytes,fact);
         if NeedBytes = 0 then begin
           New(pFIFO);
           pFIFO^.FLAP := FLAP;
           pFIFO^.Next := nil;
           GetMem(pFIFO^.DATA,Index);
           move(FLAP_DATA,PFIFO^.Data^,swap(FLAP.Len));
           // AddToLast
           CurrFIFO:=HeadFIFO;
           if HeadFIFO<>nil then begin
             while CurrFIFO<>nil do
               if CurrFIFO^.Next=nil then begin
                 CurrFIFO^.Next:=pFIFO;
                 break;
               end else CurrFIFO:=CurrFIFO^.Next;
           end else HeadFIFO:=pFIFO; // list is empty
           isHDR := not isHDR; 
         end;
     end;
end;
 
(****************************************************************)
procedure TForm1.MainTTimer(Sender: TObject);
var FindFIFO : PFLAP_Item;
    tmp : PPack;
begin
     MainT.Enabled := false;
     while HeadFIFO<>nil do begin
       // Get HeadFIFO
       FindFIFO := HeadFIFO;
       if HeadFIFO^.Next=nil then HeadFIFO := nil
       else HeadFIFO := HeadFIFO^.Next;
 
       // creating new packet
       tmp := PacketNew;
       // Fill the packet
       PacketAppend(tmp,@FindFIFO^.FLAP,sizeof(FLAP_HDR));
       PacketAppend(tmp,FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
       // Release packet`s memory
       FreeMem(FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
       Dispose(FindFIFO);
       //
       debugFILE(tmp,'<');
       if isAuth then AuthorizePart(tmp)
       else WorkPart(tmp);
       // Deleting packet
       PacketDelete(tmp);
     end;
     MainT.Enabled := true;
end;
 
(****************************************************************)
procedure TForm1.AuthorizePart(p:PPack);
var ss : string;
    T : integer;
    tmp : PPack;
begin
     PacketGoto(p,sizeof(FLAP_HDR)); // goto FLAP_DATA
 
     // Authorize Server ACK
     if (swap(p^.Len)=4)and
        (swap(p^.SNAC.FamilyID)=0)and
        (swap(p^.SNAC.SubTypeID)=1) then begin
        M(Memo,'<Authorize Server CONNECT');
 
       // Auth Request (Login)
       SEQ := random($7FFF);
       tmp := CreatePacket(1,SEQ);
       PacketAppend32(tmp,DSwap(1));
       TLVAppendStr(tmp,$1,s(UIN));
       TLVAppendStr(tmp,$2,Calc_Pass(PASSWORD));
       TLVAppendStr(tmp,$3,'ICQ Inc. - Product of ICQ (TM).2000a.4.31.1.3143.85');
       TLVAppendWord(tmp,$16,$010A);
       TLVAppendWord(tmp,$17,$0004); // for 2000a
       TLVAppendWord(tmp,$18,$001F);
       TLVAppendWord(tmp,$19,$0001);
       TLVAppendWord(tmp,$1A,$0C47);
       TLVAppendDWord(tmp,$14,$00000055);
       TLVAppendStr(tmp,$0F,'en');
       TLVAppendStr(tmp,$0E,'us');
       PacketSend(tmp);
       M(Memo,'>Auth Request (Login)');
 
     end else  // Auth Response (COOKIE or ERROR)
     if (TLVReadStr(p,ss)=1){and(ss=s(UIN))}then begin
        T := TLVReadStr(p,ss);
        case T of
          5: begin // BOS-IP:PORT
            M(Memo,'<Auth Responce (COOKIE)');
            WorkAddress := copy(ss,1,pos(':',ss)-1);
            WorkPort := strtoint(copy(ss,pos(':',ss)+1,length(ss)-pos(':',ss)));
            if (TLVReadStr(p,sCOOKIE)=6)then begin;;;;
              // Empty packet for disconnect
              tmp:=CreatePacket(4,SEQ); // ChID=4
              PacketSend(tmp);
              // Disconnect from Autorize Server
              OfflineDiscconnect1Click(self);
              isAuth := false;
              // Connecting to BOS
              CLI.Address := WorkAddress;
              CLI.Host := '';
              CLI.Port := WorkPort;
              M(Memo,'');
              M(Memo,'>>> Connecting to BOS: '+ss);
              CLI.Open;
            end;
          end;
          4,8: begin
               M(Memo,'<Auth ERROR');
               M(Memo,'TLV($'+inttohex(T,2)+') ERROR');
               M(Memo,'STRING: '+ss);
               if pos('http://',ss)>0 then begin
               end;
               TLVReadStr(p,ss); M(Memo,ss);
               OfflineDiscconnect1Click(self);
               M(Memo,'');
             end;
        end;
     end;
end;
 
(****************************************************************)
procedure TForm1.WorkPart(p:PPack);
var ss,ss2,sErr : string;
//    T : integer;
    tmp : PPack;
    i : integer;
begin
     if p^.FLAP.ChID = 4 then begin // SERVER GONNA DISCONNECT
       PacketGoto(p,sizeof(FLAP_HDR));
       TLVReadStr(p,ss); M(Memo,ss);
       TLVReadStr(p,ss2); M(Memo,ss2);
       OfflineDiscconnect1Click(self);
       sErr:='Str1: ';
       for i:=1 to length(ss) do sErr:=sErr+inttohex(byte(ss[i]),2)+' ';
       sErr:=sErr+#13#10+'Str2: '+ss2+#13#10+#13#10;
       ShowMessage('Another Computer Use YOUR UIN!'#13#10+#13#10+
                   sErr+'...i gonna to disconnect');
       exit;
     end;
 
     PacketGoto(p,sizeof(FLAP_HDR)+sizeof(SNAC_HDR));
     // BOS Connection ACK
     if (swap(p^.Len)=4)and
        (swap(p^.SNAC.FamilyID)=0)and
        (swap(p^.SNAC.SubTypeID)=1) then begin
        M(Memo,'<BOS connection ACK');
 
       // BOS Sign-ON  (COOKIE)
       SEQ := random($7FFF);
       tmp := CreatePacket(1,SEQ);
       PacketAppend32(tmp,DSwap(1));
       TLVAppendStr(tmp,$6,sCOOKIE);
       PacketSend(tmp);
       M(Memo,'>BOS Sign-ON (COOKIE)');
 
     end else  // BOS-Host ready
     if (swap(p^.SNAC.FamilyID)=1)and
        (swap(p^.SNAC.SubTypeID)=3) then begin
        M(Memo,'<BOS-Host ready');
 
       // I`m ICQ client, not AIM
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$17);
       PacketAppend32(tmp,dswap($00010003));
       PacketAppend32(tmp,dswap($00020001));
       PacketAppend32(tmp,dswap($00030001));
       PacketAppend32(tmp,dswap($00150001));
       PacketAppend32(tmp,dswap($00040001));
       PacketAppend32(tmp,dswap($00060001));
       PacketAppend32(tmp,dswap($00090001));
       PacketAppend32(tmp,dswap($000A0001));
       PacketSend(tmp);
       M(Memo,'>"I`m ICQ client, not AIM"');
 
     end else // ACK to "I`m ICQ Client"
     if (swap(p^.SNAC.FamilyID)=$1)and // ACK
        (swap(p^.SNAC.SubTypeID)=$18) then begin
        M(Memo,'<ACK to "I`m ICQ client"');
 
       // Rate Information Request
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$6);
       PacketSend(tmp);
       M(Memo,'>Rate Information Request');
 
     end else // Rate Information Response
     if (swap(p^.SNAC.FamilyID)=$1)and
        (swap(p^.SNAC.SubTypeID)=$7) then begin
        M(Memo,'<Rate Information Response');
 
       // ACK to Rate Information Response
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$8);
       PacketAppend32(tmp,DSwap($00010002));
       PacketAppend32(tmp,DSwap($00030004));
       PacketAppend16(tmp,Swap($0005));
       PacketSend(tmp);
       M(Memo,'>ACK to Rate Response');
 
       // Request Personal Info
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$0E);
       PacketSend(tmp);
       M(Memo,'>Request Personal Info');
 
       // Request Rights for Location service
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$2,$02);
       PacketSend(tmp);
       M(Memo,'>Request Rights for Location service');
 
       // Request Rights for Buddy List
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$3,$02);
       PacketSend(tmp);
       M(Memo,'>Request Rights for Buddy List');
 
       // Request Rights for ICMB
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$4,$04);
       PacketSend(tmp);
       M(Memo,'>Request Rights for ICMB');
 
       // Request BOS Rights
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$9,$02);
       PacketSend(tmp);
       M(Memo,'>Request BOS Rights');
 
     end else  // Personal Information
     if (swap(p^.SNAC.FamilyID)=$1)and
        (swap(p^.SNAC.SubTypeID)=$F) then begin
        M(Memo,'<Personal Information');
 
     end else  // Rights for location service
     if (swap(p^.SNAC.FamilyID)=$2)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'<Rights for location service');
 
     end else  // Rights for byddy list
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'<Rights for byddy list');
 
     end else  // Rights for ICMB
     if (swap(p^.SNAC.FamilyID)=$4)and
        (swap(p^.SNAC.SubTypeID)=$5) then begin
        M(Memo,'<Rights for ICMB');
 
     end else // BOS Rights
     if (swap(p^.SNAC.FamilyID)=$9)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'<BOS Rights');
 
       // Set ICMB parameters
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$4,$2);
       PacketAppend16(tmp,swap($0));
       PacketAppend32(tmp,dswap($3));
       PacketAppend16(tmp,swap($1F40));
       PacketAppend16(tmp,swap($03E7));
       PacketAppend16(tmp,swap($03E7));
       PacketAppend16(tmp,swap($0));
       PacketAppend16(tmp,swap($0));
       PacketSend(tmp);
       M(Memo,'>Set ICMB parameters');
 
       // Set User Info (capability)
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$2,$4);      // tlv(5)=capability
       TLVAppendStr(tmp,5,#$09#$46#$13#$49#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00+
                          #$09#$46#$13#$44#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00);
       PacketSend(tmp);
       M(Memo,'>Set User Info (capability)');
 
       // Send Contact List
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$3,$4);
       PacketAppendB_String(tmp,s(UIN)); 
       // PacketAppendB_String(tmp,s(someUIN)); 
       PacketSend(tmp);
       M(Memo,'>Send Contact List (1)');
 
       case ICQStatus of
       STATE_INVISIBLE: begin
           // Send Visible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$5);
           PacketSend(tmp);
           M(Memo,'>Send Visible List (0)');
         end;
       else begin
           // Send Invisible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$7);
           PacketSend(tmp);
           M(Memo,'>Send Invisible List (0)');
         end;
       end;//case
 
       ConnectMode(true);
       SetStatus(ICQStatus);
       M(Memo,'>Set Status Code');
 
       // Client Ready
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$2);
       PacketAppend32(tmp,dswap($00010003));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00020001));
       PacketAppend32(tmp,dswap($0101028A));
       PacketAppend32(tmp,dswap($00030001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00150001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00040001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00060001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00090001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($000A0003));
       PacketAppend32(tmp,dswap($0110028A));
       PacketSend(tmp);
       M(Memo,'>Client Ready');
 
       // Get offline messages
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$15,$2);
       PacketAppend32(tmp,dswap($0001000A));
       PacketAppend16(tmp,swap($0800));
       PacketAppend32(tmp,UIN);
       PacketAppend16(tmp,swap($3C00));
       PacketAppend16(tmp,swap($0200));
       PacketSend(tmp);
       M(Memo,'>Get offline messages');
 
       // Get Banner Address
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$15,$2);
       PacketAppend16(tmp,swap($0001));
       ss:='<key>BannersIP</key>';
       PacketAppend16(tmp,swap(14+length(ss)+1));
       PacketAppend16(tmp,swap($2100));
       PacketAppend32(tmp,UIN);
       PacketAppend16(tmp,swap($D007)); // Type
       PacketAppend16(tmp,swap($0300)); // Cookie
       PacketAppend16(tmp,swap($9808)); // SubType = xml-style (LNTS)
       PacketAppendString(tmp,ss); // '<key>BannersIP</key>'
       PacketSend(tmp);
       M(Memo,'>Get Banner Address');
 
     end else  // Reject notification
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0A) then begin
        M(Memo,'');
        M(Memo,'<Reject from UIN: '+PacketReadB_String(p));
        M(Memo,'');
 
     end else  // UIN ON-line
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0B) then begin
        M(Memo,'');
        ShowUserONStatus(p);
        M(Memo,'');
 
     end else  // UIN OFF-line ???
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0C) then begin
        M(Memo,'');
        M(Memo,'<UIN OFF-line: '+PacketReadB_String(p));
        M(Memo,'');
 
     end else  // SNAC 15,3  Meny purposes (offlines messages)
     if (swap(p^.SNAC.FamilyID)=$15)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'');
        SNAC_15_3(p);
        M(Memo,'');
 
     end else  // SNAC 4,7  Incoming message
     if (swap(p^.SNAC.FamilyID)=$4)and
        (swap(p^.SNAC.SubTypeID)=$7) then begin
        M(Memo,'');
        SNAC_4_7(p);
        M(Memo,'');
 
     end else begin
                M(Memo,'');
                M(Memo,'???? Unrecognized SNAC: ????????');
                M(Memo,'???? SNAC [$'+inttohex(swap(p^.SNAC.FamilyID),2)+':$'+
                                inttohex(swap(p^.SNAC.SubTypeID),2)+']');
                M(Memo,'');
              end;
end;
 
(****************************************************************)
procedure TForm1.ShowUserONStatus(p:PPack);
var T : word;
    k,cnt : integer;
    UINonline,TLV : string;
    r_ip,r_r_ip,r_status : longint;
begin
      UINonline := PacketReadB_String(p);
      M(Memo,'<UIN ON-line: '+UINonline);
      PacketRead16(p);
      cnt := swap(PacketRead16(p));
      for k:=1 to cnt do begin
        T := TLVReadStr(p,TLV);
        case T of
        6:  begin // STATUS
            move(TLV[1],IPArray(r_status),4);
            r_status := DSwap(r_status);
            M(Memo,'#'+s(k)+' TLV($'+inttohex(T,2)+')'+
                    ' STATUS: $'+inttohex(r_status,8));
            end;
        $A: begin // IP
            move(TLV[1],IPArray(r_ip),4);
            M(Memo,'#'+s(k)+' TLV($'+inttohex(T,2)+')'+
                   ' IP: '+IPToStr(IPArray(r_ip)));
            end;
        $C: begin // REAL_IP
            move(TLV[1],IPArray(r_r_ip),4);
            M(Memo,'#'+s(k)+' TLV($'+inttohex(T,2)+')'+
                   ' Real IP: '+IPToStr(IPArray(r_r_ip)));
            end;
            //else M(Memo,'??? #'+s(k)+' TLV($'+inttohex(T,2)+')');
        end;
      end;
end;
 
(****************************************************************)
procedure TForm1.SNAC_15_3(p:PPack);
var MessageType : word;
    {myUIN,}hisUIN : longint;
    SubType : array[0..3] of byte;
    MessageSubType : longint absolute SubType;
    year,month,day,hour,minute,typemes,{subtypemes,}lenmes : word;
    tmp : PPack;
    sTemp,URL : string;
begin
     PacketRead32(p);
     PacketRead16(p);
     {myUIN := }PacketRead32(p);
     MessageType := swap(PacketRead16(p));
     {Cookie := }swap(PacketRead16(p));
     //M(Memo,'<Cookie: $'+inttohex(Cookie,4));
     case MessageType of
     $DA07: begin
            SubType[3] := 0;
            SubType[2] := PacketRead8(p);
            SubType[1] := PacketRead8(p);
            SubType[0] := PacketRead8(p);
            if(MessageSubType and $FF)<>$0A then begin
              M(Memo,'<FAIL: SubType:$'+inttohex(MessageSubType,4));
            end;
            case MessageSubType of
            $A2080A: begin // Banner URL
                      sTemp := PacketReadString(p);
                      sTemp[pos('<',sTemp)] :='_';
                      URL := 'http://'+copy(sTemp,pos('>',sTemp)+1,pos('<',sTemp)-pos('>',sTemp)-1);
                      M(Memo,'<Banner HTML-Server: '+URL);
                     end;
            else M(Memo,'<??? SNAC 15,3; Type:$DA07; SubType: $'+inttohex(MessageSubType,6));
            end;//
            end;
 
     $4200: begin // END of offline messages
            //M(Memo,'<Message-Type: $'+inttohex(MessageType,4));
            M(Memo,'<End of OFFline messages');
            tmp := CreatePacket(2,SEQ);
            SNACAppend(tmp,$15,$2);
            PacketAppend16(tmp,swap($0001)); // TLV(1)
            PacketAppend32(tmp,dswap($000A0800));
            PacketAppend32(tmp,UIN);
            PacketAppend16(tmp,swap($3E00)); // ACK
            PacketAppend16(tmp,swap($0200));
            PacketSend(tmp);
            //M(Memo,'>ACK it');
            end;
     $4100: begin // OFFLINE MESSAGE
            hisUIN := PacketRead32(p); // LE
            //M(Memo,'<Message-Type: $'+inttohex(MessageType,4));
            M(Memo,'<OFFLINE MESSAGE from UIN: '+s(hisUIN));
            year := PacketRead16(p);
            month := PacketRead8(p);
            day := PacketRead8(p);
            hour := PacketRead8(p);
            minute := PacketRead8(p);
            typemes := PacketRead8(p);
            {subtypemes := }PacketRead8(p);
            lenmes := PacketRead16(p);
            DoMsg(false,typemes,lenmes,PCharArray(@(p^.data[p^.cursor])),
                  hisUIN,UTC2LT(year,month,day,hour,minute));
            end;
     else M(Memo,'<??? SNAC 15,3; Type: $'+inttohex(MessageType,4));
     end;//case
end;
 
(****************************************************************)
procedure TForm1.SNAC_4_7(p:PPack);  // INCOMING MESSAGES
var i,cnt,T,MessageFormat,SubMode,SubMode2,Empty : word;
    {myUIN,}hisUIN : longint;
    SubType : array[0..3] of byte;
    MessageSubType : longint absolute SubType;
    tmp,tmp2,tmp3 : PPack;
    sTemp : string;
    dTemp : TByteArray;
    typemes,{subtypemes,}unk,modifier,lenmes : word;
 
    //for snac 4,0B  (ack for msg-2 type)
    d1,d2 : longint;
    ACK : TByteArray;
    ind : word;
 
begin
     d1:=PacketRead32(p);
     d2:=PacketRead32(p);
     MessageFormat := swap(PacketRead16(p));
     sTemp := PacketReadB_String(p);
     ind:=0;
     PLONG(@(ACK[ind]))^:=d1; inc(ind,4);
     PLONG(@(ACK[ind]))^:=d2; inc(ind,4);
     PWORD(@(ACK[ind]))^:=swap(MessageFormat);inc(ind,2);
     PBYTE(@(ACK[ind]))^:=length(sTemp);inc(ind,1);
     MOVE(sTemp[1],ACK[ind],length(sTemp));inc(ind,length(sTemp));
     PWORD(@(ACK[ind]))^:=swap($0003);inc(ind,2);
 
     try hisUIN := strtoint(sTemp); except hisUIN:=0; end;
     M(Memo,'<From: '+sTemp);
     PacketRead16(p); //warning level? garbage of OSCAR protocol
     cnt := swap(PacketRead16(p)); // num of TLVs
     for i:=1 to cnt do
       if TLVReadStr(p,sTemp)=6 then begin { this is a HIS STATUS } end;
     case MessageFormat of
     $0001: begin
            //M(Memo,'<Message-format: 1 (SIMPLY message)');
            TLVReadStr(p,sTemp);
            // copy TLV(2) to TMP
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0); // goto !!!!!
            // work it
            PacketRead16(tmp);
            PacketRead16(tmp);
            PacketRead8(tmp);
            PacketRead16(tmp);
            lenmes := swap(PacketRead16(tmp))-4;
            PacketRead32(tmp);
 
            PacketRead(tmp,@sTemp[1],lenmes);
            SetLength(sTemp,lenmes);
            DoSimpleMsg(hisUIN,sTemp);
 
            // delete TMP
            PacketDelete(tmp);
            end;
     $0002: begin
            //M(Memo,'<Message-format: 2 (ADVANCED message)');
            TLVReadStr(p,sTemp);
            // copy TLV(5) to TMP
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0); // goto !!!!!
            // work it
            SubMode := swap(PacketRead16(tmp));
            PacketRead32(tmp);
            PacketRead32(tmp);
            PacketRead(tmp,@dTemp,16); //capability 16 bytes
            case SubMode of
            $0000: begin
                   //M(Memo,'SubMode: $0000 NORMAL');
                   {T := }TLVReadWord(tmp,SubMode2);// 0001-normal 0002-file reply
                   TLVReadWord(tmp,Empty);// TLV(F) empty
                   T := TLVReadStr(tmp,sTemp);
                   if T=$2711 then begin
 
                   MOVE(sTemp[1],ACK[ind],47);inc(ind,47);
                   PLONG(@(ACK[ind]))^:=0; inc(ind,4);
 
                   //******************************************
                   tmp2 := PacketNew;
                   PacketAppend(tmp2,@(sTemp[1]),length(sTemp));
                   PacketGoto(tmp2,0); // goto !!!!!
                   PacketRead(tmp2,@dTemp,26);
                   PacketRead8(tmp2);
                   PacketRead16(tmp2);
                   PacketRead16(tmp2);
                   PacketRead16(tmp2);
                   PacketRead(tmp2,@dTemp,12);
                   typemes := PacketRead8(tmp2);
                   {subtypemes := }PacketRead8(tmp2);
                   unk:=swap(PacketRead16(tmp2));//0200
                   modifier:=swap(PacketRead16(tmp2));//0100
                   M(Memo,'Unk: $'+inttohex(unk,4));
                   M(Memo,'Modifier: $'+inttohex(modifier,4));
 
                   lenmes := PacketRead16(tmp2);
                   DoMsg(true,typemes,lenmes,PCharArray(@(tmp2^.data[tmp2^.cursor])),
                         hisUIN,Now2DateTime);
                   // delete TMP2
                   PacketDelete(tmp2);
 
                   PWORD(@(ACK[ind]))^:=1; inc(ind,2);
                   PBYTE(@(ACK[ind]))^:=0; inc(ind,1);
                   PLONG(@(ACK[ind]))^:=0; inc(ind,4);
                   PLONG(@(ACK[ind]))^:=-1; inc(ind,4);
 
                   // Sending Ack
                   tmp3 := CreatePacket($2,SEQ);
                   SNACAppend(tmp3,$4,$0B);
                   PacketAppend(tmp3,@ACK[0],ind);
                   PacketSend(tmp3);
                   //******************************************
                   end;// IF
                   end;  //Submode:$0000
            $0001: M(Memo,'SubMode:$0001 ??? message canceled ???');
            $0002: M(Memo,'SubMode:$0002 FILE-ACK (not yet)');
            end;//case SubMode
            // delete TMP
            PacketDelete(tmp);
            end;
     $0004: begin
            //M(Memo,'<Message-format: 4 (url or contacts or auth-req or userAddedYou)');
            TLVReadStr(p,sTemp);
            // copy TLV(5) to TMP
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0); // goto !!!!!
            // work it
            hisUIN := PacketRead32(tmp);
            typemes := PacketRead8(tmp);
            {subtypemes := }PacketRead8(tmp);
            lenmes := PacketRead16(tmp);
            DoMsg(true,typemes,lenmes,PCharArray(@(tmp^.data[tmp^.cursor])),
                  hisUIN,Now2DateTime);
            // delete TMP
            PacketDelete(tmp);
            end;
       else M(Memo,'<??? SNAC 4,7; Message-format: '+s(MessageFormat));
     end;//case MessageFormat
end;
 
(****************************************************************)
procedure TForm1.DoMsg(on_off:boolean;typemes,lenmes:integer; data:PCharArray; r_uin:longint; DateTime:TDateTime);
var i,pos1,pos2 : integer;
    sTemp,sLog,sNN,sDT : string;
    LTemp : array[1..6] of string;
begin
     if (lenmes-1)=0 then exit;
     setlength(sTemp,lenmes-1);   // -1 for final string char #0
     move(data^,sTemp[1],lenmes-1);
 
     for i:=1 to 6 do LTemp[i]:='';
     if (typemes <> TYPE_MSG)and(typemes<>0) then begin
         if sTemp[length(sTemp)]<>#$FE then sTemp:=sTemp+#$FE;
         pos2:=0;
         for i:=1 to 6 do begin
           pos1 := pos2+1;
           pos2 := pos(#$FE,sTemp);
           if pos2 = 0 then break;
           LTemp[i] := copy(sTemp,pos1,pos2-pos1);
           sTemp[pos2] := #$FF;
         end;
     end;
     sNN := '';
     case on_off of
       true: sDT := '<-[A] ';
       false: sDT := '<-[O] ';
     end;
     sDT := sDT+DateTimeToStr(DateTime)+' ';
     case typemes of
     0,TYPE_MSG:
        FmtStr(sLog,sNN+' ['+s(r_uin)+'] "%s"',[sTemp]);
     TYPE_ADDED:
        FmtStr(sLog,'UIN:%d has added you to their contact list.'+
                    'Nick:%s  FName:%s LName:%s E-mail:%s',
                    [r_uin,LTemp[1],LTemp[2],LTemp[3],LTemp[4]]);
     TYPE_AUTH_REQ:
        FmtStr(sLog,'UIN:%d has requested your authorization.'+
                    'Nick:%s  FName:%s LName:%s E-mail:%s '#13#10'Reason:"%s"',
                    [r_uin,LTemp[1],LTemp[2],LTemp[3],LTemp[4],LTemp[6]]);
     TYPE_URL:
        FmtStr(sLog,'URL: UIN:%d, '#13#10'URL:%s, '#13#10'Description:"%s"',
                    [r_uin,LTemp[2],LTemp[1]]);
     TYPE_WEBPAGER:
        FmtStr(sLog,'WebPager: UIN:%d, Nick:%s, EMail:%s, '#13#10'"%s"',
                    [r_uin,LTemp[1],LTemp[4],LTemp[6]]);
     TYPE_EXPRESS:
        FmtStr(sLog,'MailExpress: UIN:%d, Nick:%s, EMail:%s, '#13#10'"%s"',
                    [r_uin,LTemp[1],LTemp[4],LTemp[6]]);
     else FmtStr(sLog,'Instant message type %d from UIN:%d, '#13#10'Message:"%s"',
                    [typemes,r_uin,sTemp]);
     end;//case
     sLog := sDT+sLog;
     M(Memo,sLog); LogMessage(sLog);
end;
 
(****************************************************************)
procedure TForm1.DoSimpleMsg(r_uin:longint; Text:string);
var sLog : string;
begin
     sLog:= '<-[S] '+DateTimeToStr(Now)+' '+'['+s(r_uin)+'] "'+Text+'"';
     M(Memo,sLog);   LogMessage(sLog);
end;
(****************************************************************)
procedure TForm1.SetStatus(Status:longint);
var tmp : PPack;
begin
       ICQStatus := Status;
       // Set Status Code
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$1E);
       TLVAppendDWord(tmp,6,ICQStatus);
       TLVAppendWord(tmp,8,$0000);
       // imitation TLV(C)
       PacketAppend32(tmp,dswap($000C0025)); // TLV(C)
       StrToIP(Get_my_IP,DIM_IP);
       PacketAppend(tmp,@DIM_IP,4); // IP address
       PacketAppend32(tmp,dswap(28000+random(1000)));// Port
       PacketAppend8(tmp,$04);
       PacketAppend16(tmp,swap($0007));
       PacketAppend16(tmp,swap($466B));
       PacketAppend16(tmp,swap($AE68));
       PacketAppend32(tmp,dswap($00000050));
       PacketAppend32(tmp,dswap($00000003));
       PacketAppend32(tmp,dswap(SecsSince1970));
       PacketAppend32(tmp,dswap(SecsSince1970));
       PacketAppend32(tmp,dswap(SecsSince1970));
       PacketAppend16(tmp,swap($0000));
       PacketSend(tmp);
       case ICQStatus of
         STATE_ONLINE:      StatusBtn.Caption := 'online';
         STATE_AWAY:        StatusBtn.Caption := 'away';
         STATE_DND:         StatusBtn.Caption := 'dnd';
         STATE_OCCUPIED:    StatusBtn.Caption := 'occupied';
         STATE_FREEFORCHAT: StatusBtn.Caption := 'freeforchat';
         STATE_N_A:         StatusBtn.Caption := 'na';
         STATE_INVISIBLE:   StatusBtn.Caption := 'invisible';
         else               StatusBtn.Caption := 'offline';
       end;
end;
 
(****************************************************************)
procedure TForm1.StatusChange(Status:longint);
var tmp : PPack;
begin
     if(not OL)then begin
       Get_My_IP;
       if not OL then begin
         M(Memo,'OFF-line');
         exit;
       end;
     end;
     if (not CLI.Active) then icq_Login(Status)
     else if (not isLogged) then exit  // logging now ...
     else begin
       ICQStatus := Status;
       case ICQStatus of
       STATE_INVISIBLE: begin
           // Send Visible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$5);
           PacketSend(tmp);
           M(Memo,'>Send Visible List (0)');
         end;
       else begin
           // Send Invisible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$7);
           PacketSend(tmp);
           M(Memo,'>Send Invisible List (0)');
         end;
       end;//case
       // Set Status Code
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$1E);
       TLVAppendDWord(tmp,6,ICQStatus);
       PacketSend(tmp);
       case ICQStatus of
         STATE_ONLINE:      StatusBtn.Caption := 'online';
         STATE_AWAY:        StatusBtn.Caption := 'away';
         STATE_DND:         StatusBtn.Caption := 'dnd';
         STATE_OCCUPIED:    StatusBtn.Caption := 'occupied';
         STATE_FREEFORCHAT: StatusBtn.Caption := 'freeforchat';
         STATE_N_A:         StatusBtn.Caption := 'na';
         STATE_INVISIBLE:   StatusBtn.Caption := 'invisible';
         else               StatusBtn.Caption := 'offline';
       end;
     end;
end;
 
(****************************************************************)
procedure TForm1.OnlineConnected1Click(Sender: TObject);
begin
     StatusChange(STATE_ONLINE);
end;
 
(****************************************************************)
procedure TForm1.Away1Click(Sender: TObject);
begin
      StatusChange(STATE_AWAY);
end;
 
(****************************************************************)
procedure TForm1.DNDDoNotDisturb1Click(Sender: TObject);
begin
      StatusChange(STATE_DND);
end;
 
(****************************************************************)
procedure TForm1.PrivacyInvisible1Click(Sender: TObject);
begin
      StatusChange(STATE_INVISIBLE);
end;
 
(****************************************************************)
procedure TForm1.OfflineDiscconnect1Click(Sender: TObject);
begin
     ConnectMode(false);
end;
 
(****************************************************************)
procedure TForm1.OccupiedUrgentMsgs1Click(Sender: TObject);
begin
      StatusChange(STATE_OCCUPIED);
end;
 
(****************************************************************)
procedure TForm1.FreeForChat1Click(Sender: TObject);
begin
      StatusChange(STATE_FREEFORCHAT);
end;
 
(****************************************************************)
procedure TForm1.NAExtendedAway1Click(Sender: TObject);
begin
      StatusChange(STATE_N_A);
end;
 
(****************************************************************)
procedure TForm1.icq_Login(Status : longint);
begin
     randomize;
     SEQ := random($7FFF);
     Local_IP := Get_my_IP;
     StrToIP(Local_IP,DIM_IP);
     ICQStatus := status;
     if CLI.Active then CLI.Close;
     isAuth := true;
     isHDR := true;
     CLI.Address :='';
     CLI.Host := 'login.icq.com';
     CLI.Port := 5190;
     M(Memo,'>>>>>>>>>>  login.icq.com:5190 <<<<<<<<<<<');
     CLI.Open;
end;
 
(****************************************************************)
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     OfflineDiscconnect1Click(self);
     CloseLogs;
end;
 
(****************************************************************)
procedure TForm1.InitLogs;
begin
     assignfile(mess,s(UIN)+'.mes');
     try  if FileExists(s(UIN)+'.mes') then append(mess)
          else rewrite(mess);
     M(Memo,DateTimeToStr(Now));
     except end;
     assignfile(log,s(UIN)+'.log');
     try if FileExists(s(UIN)+'.log') then append(log)
         else rewrite(log);
     except end;
end;
 
(****************************************************************)
procedure TForm1.CloseLogs;
begin
     try closefile(mess); except end;
     try closefile(log);  except end;
end;
 
(****************************************************************)
procedure TForm1.LogMessage(s:string);
begin
     try writeln(mess,s); except end;
end;
 
(****************************************************************)
procedure TForm1.InitUser;
var cfg : TIniFile;
begin
     cfg := TIniFile.Create(ExtractFilePath(ParamStr(0))+'nICQ.ini');
     try
     UIN := cfg.ReadInteger('User','Uin',0);
     NICK := cfg.ReadString('User','Nick','');
     PASSWORD := cfg.ReadString('User','Password','');
     finally cfg.Free; end;
     Caption := NICK+' : '+s(UIN);
end;
 
(****************************************************************)
procedure TForm1.ClearFIFO;
var Find : PFLAP_Item;
begin
   repeat
     Find := HeadFIFO;
     if HeadFIFO<>nil then begin
       if HeadFIFO^.Next<>nil then
         HeadFIFO := HeadFIFO^.Next
       else HeadFIFO := nil;
     end;
     if Find<>nil then begin
       FreeMem(Find^.DATA,swap(Find^.FLAP.Len));
       Dispose(Find);
     end;
   until Find=nil;
end;
 
(****************************************************************)
 
procedure TForm1.StatusBtnClick(Sender: TObject);
begin
     StatusMenu.Popup(Left+Width-20,Top+Height-50);
end;
 
end.