Rambler's Top100
Рейтинг@Mail.ru

КомпьюТоп - каталог компьютерных сайтов





































































 
    вернуться назад Шутка...
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;
    ToolBar1: TToolBar;
    StatusBtn: TToolButton;
    Splitter1: TSplitter;
    CLI: TClientSocket;
    BG: TPanel;
    Memo: TMemo;
    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);
  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; // case
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  // is it a flap header ?
       if num>=6 then begin
         Socket.ReceiveBuf(FLAP,6);
         NeedBytes := swap(FLAP.Len);
         Index := 0;   // FLAP_DATA[0]
         isHDR := not isHDR; // goto FLAP_DATA
       end else begin
             M(memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
             Socket.ReceiveBuf(buf,num);
             M(Memo,Dim2Hex(@(buf),num));
             M(memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
           end;

     end else begin  // DATA-BLOCK
         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));
           // AddLast
           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; // goto FLAP_HDR
         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:='BannersIP';
       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); // 'BannersIP'
       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)');
            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
     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);
var  cfg : TIniFile;
begin
     randomize;  
     SEQ := random($7FFF);
     Local_IP := Get_my_IP; 
     StrToIP(Local_IP,DIM_IP);
     cfg := TIniFile.Create(ExtractFilePath(ParamStr(0))+'nICQ.ini');
     try initStatus := cfg.ReadInteger('User','Status',online);
     finally cfg.Free; end;
     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
   // Del ALL
   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;

(****************************************************************)

end.