{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
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^. := 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^.=nil then begin
  CurrFIFO^.:=pFIFO;
  break;
  end else CurrFIFO:=CurrFIFO^.;
  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^.=nil then HeadFIFO := nil
  else HeadFIFO := HeadFIFO^.;
  // 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^.<>nil then
  HeadFIFO := HeadFIFO^.
  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,+Height-50);
end;
end.