Delphi控件源码

开发平台：

Delphi

ICQWorks.pas：源码内容

Data: TRawPkt;
Pkt1: TRawPkt;
const
TextCMD = 'File Transfer';
begin
PktInitRaw(@Data); //Additional data packet
PktInitRaw(@Pkt1); //First temporary packet
PktAddArrBuf(@Pkt1, @FileSignature, 16); //File signature
PktInt(@Pkt1, $0000, 2); //Unknown: empty
PktDWStr(@Pkt1, TextCMD); //Text command
PktInt(@Pkt1, $00000101, 4); //Unknown
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $0000, 2); //Unknown
PktInt(@Pkt1, $00, 1); //Unknown
PktLInt(@Data, Pkt1.Len, 2); //Length of the first temp packet
PktAddArrBuf(@Data, @Pkt1, Pkt1.Len); //Implode packets
PktInitRaw(@Pkt1); //Second additional packet
PktDWStr(@Pkt1, FileDesc); //File description
PktInt(@Pkt1, Port, 2); //Listeners port
PktInt(@Pkt1, $0000, 2); //Unknown
PktLNTS(@Pkt1, FileName); //Filename
PktLInt(@Pkt1, FileSize, 4); //Filesize
PktLInt(@Pkt1, Port, 4); //Listeners port again
PktLInt(@Data, Pkt1.Len, 4); //Length of the second temp packet
PktAddArrBuf(@Data, @Pkt1, Pkt1.Len); //Implode packets
CreateCLI_SENDADVMSG_CUSTOM(Pkt, FFSeq, ITime, IRandom, UIN, $1a, $00, $0002, '', @Data, Data.Len, False, Seq);
end;
{Request an auto-away message.}
procedure CreateCLI_REQAWAYMSG(Pkt: PRawPkt; ITime, IRandom, UIN: LongWord; Status: Byte; var Seq: Word);
begin
CreateCLI_SENDADVMSG_CUSTOM(Pkt, $FFFF, ITime, IRandom, UIN, Status, $03, $0001, '', nil, 0, False, Seq);
end;
{Send contacts through server.}
procedure CreateCLI_SENDCONTACTS(Pkt: PRawPkt; ITime, IRandom, UIN: LongWord; Contacts: TStringList; var Seq: Word);
var
lpData: TRawPkt;
Pkt1: TRawPkt;
S: String;
const
TextCMD = 'Contacts';
begin
PktInitRaw(@lpData); //Init data packet
PktInitRaw(@Pkt1); //Init first temporary packet
PktAddArrBuf(@Pkt1, @ContactsSignature, 16); //Contacs signature
PktInt(@Pkt1, $0000, 2); //0x0000 - Send contacts
PktDWStr(@Pkt1, TextCMD); //Text command
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $00010000, 4); //Unknown
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $0000, 2); //Unknown
PktInt(@Pkt1, $00, 1); //Unknown
PktLInt(@lpData, Pkt1.Len, 2); //Length of the following packet (Pkt1)
PktAddArrBuf(@lpData, @Pkt1, Pkt1.Len); //Implode packets
S := MakeContactsStr(Contacts); //Create text list from string list
PktLInt(@lpData, Length(S) + 4, 4); //Length of the following data
PktDWStr(@lpData, S); //Length of the following string
CreateCLI_SENDADVMSG_CUSTOM(Pkt, $FFFF, ITime, IRandom, UIN, $1a, $00, $0001, '', @lpData, lpData.Len, False, Seq);
end;
{Send contacts request through server.}
procedure CreateCLI_SENDCONTACTS_REQ(Pkt: PRawPkt; ITime, IRandom, UIN: LongWord; Reason: String; var Seq: Word);
var
lpData: TRawPkt;
Pkt1: TRawPkt;
const
TextCMD = 'Request For Contacts';
begin
PktInitRaw(@lpData); //Init data packet
PktInitRaw(@Pkt1); //Init first temporary packet
PktAddArrBuf(@Pkt1, @ContactsSignature, 16); //Contacs signature
PktInt(@Pkt1, $0200, 2); //0x0200 - Request for contacts
PktDWStr(@Pkt1, TextCMD); //Text command
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $00010000, 4); //Unknown
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $0000, 2); //Unknown
PktInt(@Pkt1, $00, 1); //Unknown
PktLInt(@lpData, Pkt1.Len, 2); //Length of the following packet (Pkt1)
PktAddArrBuf(@lpData, @Pkt1, Pkt1.Len); //Implode packets
PktLInt(@lpData, Length(Reason) + 4, 4); //Length of the following data
PktDWStr(@lpData, Reason); //Length of the following string
CreateCLI_SENDADVMSG_CUSTOM(Pkt, $FFFF, ITime, IRandom, UIN, $1a, $00, $0001, '', @lpData, lpData.Len, False, Seq);
end;
{Create a FILE_ACK showing that user declined file.}
procedure CreateCLI_SENDMSG_FILEDECLINE(Pkt: PRawPkt; FFSeq: Word; ITime, IRandom, UIN, FileSize: LongWord; const FileDesc, FileName, Reason: String; Port: Word; var Seq: Word);
var
Pkt1: TRawPkt;
const
TextCMD = 'File Transfer';
begin
PktInit(Pkt, 2, Seq);
PktSnac(Pkt, $04, $0b, $00000000, $0000);
PktInt(Pkt, ITime, 4); //Time
PktInt(Pkt, IRandom, 2); //RandomID
PktInt(Pkt, $0000, 2); //Unknown
PktInt(Pkt, $0002, 2); //Message type
PktLStr(Pkt, UIN); //Destination UIN
PktInt(Pkt, $0003, 2); //Unknown
PktInt(Pkt, $1b00, 2); //If this value is not present, this is not a message packet.
PktInt(Pkt, $0800, 2); //TCP version
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $0000, 2); //Unknown: empty
PktInt(Pkt, $03, 1); //Unknown: 0x03
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, FFSeq, 2); //SEQ1
PktInt(Pkt, $0e00, 2); //Unknown, seen: 0x1200 and 0x0e00.
PktInt(Pkt, FFSeq, 2); //SEQ1
PktInt(Pkt, $00000000, 4); //Capability: empty
PktInt(Pkt, $00000000, 4); //Capability: empty
PktInt(Pkt, $00000000, 4); //Capability: empty
PktInt(Pkt, $1a00, 2); //SUBCMD
PktInt(Pkt, $01000000, 4); //Unknown
if Length(Reason) = 0 then //Use null terminator as a message, even when reason is empty
begin
PktInt(Pkt, $0100, 2);
PktInt(Pkt, $00, 1);
end else
PktLNTS(Pkt, Reason); //Reason
PktInitRaw(@Pkt1); //Initialize raw packet
PktAddArrBuf(@Pkt1, @FileSignature, 16); //File signature
PktInt(@Pkt1, $0000, 2); //Unknown: empty
PktDWStr(@Pkt1, TextCMD); //Text command
PktInt(@Pkt1, $00000101, 4); //Unknown
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $00000000, 4); //Unknown
PktInt(@Pkt1, $0000, 2); //Unknown
PktInt(@Pkt1, $00, 1); //Unknown
PktLInt(Pkt, Pkt1.Len, 2); //Length of the first temp packet
PktAddArrBuf(Pkt, @Pkt1, Pkt1.Len); //Implode packets
PktInitRaw(@Pkt1); //Second additional packet
PktDWStr(@Pkt1, FileDesc); //File description
PktInt(@Pkt1, Port, 2); //Listeners port
PktInt(@Pkt1, $0000, 2); //Unknown
PktLNTS(@Pkt1, FileName); //Filename
PktLInt(@Pkt1, FileSize, 4); //Filesize
PktLInt(@Pkt1, Port, 4); //Listeners port again
PktLInt(Pkt, Pkt1.Len, 4); //Length of the second temp packet
PktAddArrBuf(Pkt, @Pkt1, Pkt1.Len); //Implode packets
PktFinal(Pkt); //Finalize packet
end;
{Sends CLI_HELLO, used in registering the new UIN}
procedure CreateCLI_HELLO(Pkt: PRawPkt; var Seq: Word);
begin
PktInit(Pkt, 1, Seq); //Channel 2
PktInt(Pkt, $00000001, 4); //Always sent as the first parameter of a Channel 1 packet.
PktFinal(Pkt); //Finalize packet
end;
{Sends CLI_HELLO, used in unregistering the existing UIN}
procedure CreateCLI_GOODBYE(Pkt: PRawPkt; var Seq: Word);
begin
PktInit(Pkt, 1, Seq); //Channel 2
PktFinal(Pkt); //Finalize packet
end;
{Register a new UIN.}
procedure CreateCLI_REGISTERUSER(Pkt: PRawPkt; const Password: String; var Seq: Word);
var
lpTLV01: TRawPkt;
begin
PktInit(Pkt, 2, Seq); //Channel 2
PktSnac(Pkt, $17, $04, 0, 0); //Snac: Type x17/x04, ID x0000, Flags 0
PktInitRaw(@lpTLV01); //TLV(01), - this TLV contains all information needed to request a new UIN.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktInt(@lpTLV01, $28000300, 4); //Unknown.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktInt(@lpTLV01, $9E270000, 4); //Unknown. Seen: 03 46 00 00, B4 25 00 00, 9E 27 00 00.
PktInt(@lpTLV01, $9E270000, 4); //Same UNKNOWN2 as above.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktInt(@lpTLV01, $00000000, 4); //Unknown: empty.
PktLNTS(@lpTLV01, Password); //The password to use with your new UIN.
PktInt(@lpTLV01, $9E270000, 4); //The same UNKNOWN2 again.
PktInt(@lpTLV01, $0000, 2); //Unknown: empty.
PktInt(@lpTLV01, $0302, 2); //Unknown. Seen: CF 01, 03 02.
PktTLV(Pkt, $01, lpTLV01.Len, @lpTLV01); //Incapsulate TLV01 into Pkt
PktFinal(Pkt); //Finalize packet
end;
{Unregister an UIN number.}
procedure CreateCLI_UNREGUIN(Pkt: PRawPkt; UIN: LongWord; const Password: String; var Seq, Seq2: Word);
var
lpkt: TRawPkt;
begin
PktInitRaw(@lpkt);
PktInt(@lpkt, $c404, 2); //CLI_METAUNREG Channel: 2, SNAC(21,2) 2000/1220
PktLInt(@lpkt, UIN, 4); //User's UIN
PktLNTS(@lpkt, Password); //User's Password
CreateCLI_TOICQSRV(Pkt, UIN, $07D0, @lpkt, lpkt.Len, Seq, Seq2); //Incapsulate in CLI_TOICQSRV
end;
{Change user's password.}
procedure CreateCLI_METASETPASS(Pkt: PRawPkt; UIN: LongWord; const Password: String; Buffer: Pointer; BufLen: Word; var Seq, Seq2: Word);
var
lpkt: TRawPkt;
begin
PktInitRaw(@lpkt);
PktInt(@lpkt, $2e04, 2); //CLI_METASETPASS Channel: 2, SNAC(21,2) 2000/1070
if Buffer <> nil then
begin
if BufLen > 0 then
begin
PktLInt(@lpkt, BufLen + 1, 2);
PktAddArrBuf(@lpkt, Buffer, BufLen);
PktInt(@lpkt, $00, 1);
end else
PktLInt(@lpkt, $0000, 2);
end else
PktLNTS(@lpkt, Password); //User's Password
CreateCLI_TOICQSRV(Pkt, UIN, $07D0, @lpkt, lpkt.Len, Seq, Seq2); //Incapsulate in CLI_TOICQSRV
end;
{Set permissions.}
procedure CreateCLI_METASETPERMISSIONS(Pkt: PRawPkt; UIN: LongWord; AuthorizationRequired, WebAware: Boolean; var Seq, Seq2: Word);
var
lpkt: TRawPkt;
begin
PktInitRaw(@lpkt);
PktInt(@lpkt, $2404, 2); //CLI_METASETPERMISSION Channel: 2, SNAC(21,2) 2000/1060
PktInt(@lpkt, Ord(not AuthorizationRequired), 1); //Authorization required?
PktInt(@lpkt, Ord(WebAware), 1); //Webaware?
PktInt(@lpkt, $0100, 2); //Unknown: 01 00
CreateCLI_TOICQSRV(Pkt, UIN, $07D0, @lpkt, lpkt.Len, Seq, Seq2); //Incapsulate in CLI_TOICQSRV
end;
procedure CreateCLI_METAREQINFO_SHORT(Pkt: PRawPkt; UIN, DestUIN: LongWord; var Seq, Seq2: Word);
var
lpkt: TRawPkt;
begin
PktInitRaw(@lpkt);
PktInt(@lpkt, $BA04, 2); //CLI_METAREQINFO_SHORT Channel: 2, SNAC(21,2) 2000/1210
PktLInt(@lpkt, DestUIN, 4);
CreateCLI_TOICQSRV(Pkt, UIN, $07D0, @lpkt, lpkt.Len, Seq, Seq2); //Incapsulate in CLI_TOICQSRV
end;
{Request authorization from another user so we can add them to our contact list.}
procedure CreateCLI_REQAUTH(Pkt: PRawPkt; UIN: LongWord; Msg: String; var Seq: Word);
begin
PktInit(Pkt, 2, Seq); //Channel 2
PktSnac(Pkt, $13, $18, $18, 0); //SNAC: 0x13/0x18, Ref 0x00000018, Flags 0
PktLStr(Pkt, UIN); //The UIN of the user authorization is requested from.
PktWStr(Pkt, Msg); //Message sent to user in the authorization request.
PktInt(Pkt, $0000, 2); //Unknown: empty.
PktFinal(Pkt); //Finalize packet.
end;
{Keep alive packet.}
procedure CreateCLI_KEEPALIVE(Pkt: PRawPkt; var Seq: Word);
begin
PktInit(Pkt, 5, Seq); //Channel 5
PktFinal(Pkt); //Finalize packet
end;
{This SNAC is sent just before CLI_ADDBUDDY when adding a new contact to the
contact list. This SNAC is NOT sent when adding a UIN to the Ignore list. A
CLI_ADDEND when finished modifying the server side contact list.}
procedure CreateCLI_ADDSTART(Pkt: PRawPkt; FirstUpload: Boolean; var Seq: Word);
begin
PktInit(Pkt, 2, Seq); //Channel 2
PktSnac(Pkt, $13, $11, $00000011, 0); //SNAC: 0x13/0x18, Ref 0x00000011, Flags 0
if FirstUpload then
PktInt(Pkt, $00010000, 4); //Add 0x00010000 value when uploading w/o authorization
PktFinal(Pkt); //Finalize packet
end;
{This SNAC is sent to tell the server that modifications to the server side contact
list are finished.}
procedure CreateCLI_ADDEND(Pkt: PRawPkt; var Seq: Word);
begin
PktInit(Pkt, 2, Seq); //Channel 2
PktSnac(Pkt, $13, $12, $00000012, 0); //SNAC: 0x13/0x18, Ref 0x00000012, Flags 0
PktFinal(Pkt); //Finalize packet
end;
{This SNAC contains a single header group as described in SRV_REPLYROSTER. Sent
when a user is added to the contact list and updates the server side contact list.}
procedure CreateCLI_UPDATEGROUP(Pkt: PRawPkt; Name: String; Tag: Word; IDs: TStringList; var Seq: Word);
var
TLVC8: TRawPkt;
i: Word;
begin
PktInit(Pkt, 2, Seq); //Channel 2
PktSnac(Pkt, $13, $09, 0, 0); //SNAC: 0x13/0x09, Ref 0x00000000, Flags 0
{Create temporary array with group values}
PktInitRaw(@TLVC8);
if IDs.Count > 0 then
for i := 0 to IDs.Count - 1 do
PktInt(@TLVC8, StrToInt(IDs.Strings[i]), 2);
PktWStr(Pkt, StrToUTF8(Name)); //The name of this group.
PktInt(Pkt, Tag, 2); //The tag ID of this group. All members of this group have the same ID.
PktInt(Pkt, $0000, 2); //The individual ID assigned to a contact. 0 for group headers.
PktInt(Pkt, $0001, 2); //The type of the group. 0x0001 - Larger grouping header.
PktInt(Pkt, TLVC8.Len + 4, 2); //The number of bytes in the following TLVs. May be zero.
PktTLV(Pkt, $00c8, TLVC8.Len, @TLVC8); //Sent only with group header, a list of all IDs in this group.
PktFinal(Pkt); //Finalize packet
end;
{Same as CreateCLI_UPDATEGROUP modified to use only with buddies. Prototype. Can be used for UPDATEBUDDY and ADDBUDDY}
procedure __CreateCLI_UPDATEBUDDY(Pkt: PRawPkt; A: Byte; UIN, Name, SMSNumber: String; Tag, ID: Word; BuddyType: Word; NotAuthorized, IsGroup: Boolean; var Seq: Word);
var
TLVs: TRawPkt;
begin
PktInit(Pkt, 2, Seq); //Channel 2
PktSnac(Pkt, $13, A, 0, 0); //SNAC: 0x13/0x08|0x09, Ref 0x00000000, Flags 0
{Create temporary array with addition TLVs}
PktInitRaw(@TLVs);
if Name <> '' then
PktTLV(@TLVs, $0131, StrToUTF8(Name));
if NotAuthorized then
PktTLV(@TLVs, $0066, 0, 0);
if SMSNumber <> '' then
PktTLV(@TLVs, $013A, StrToUTF8(SMSNumber));
PktWStr(Pkt, UIN); //The name of this group/buddy's UIN
PktInt(Pkt, Tag, 2); //The tag ID of this group. All members of this group have the same ID.
PktInt(Pkt, ID, 2); //The individual ID assigned to a contact. 0 for group headers.
PktInt(Pkt, BuddyType, 2); //The type of the buddy.
if IsGroup or ((A = $0A) and (TLVs.Len <> 0)) or (A <> $0A) then
PktInt(Pkt, TLVs.Len, 2); //The number of bytes in the following TLVs. May be zero.
PktAddArrBuf(Pkt, @TLVs, TLVs.Len); //Sent only with group header, a list of all IDs in this group.
PktFinal(Pkt); //Finalize packet
end;
{Update SSL buddy.}
procedure CreateCLI_UPDATEBUDDY(Pkt: PRawPkt; UIN, Name, SMSNumber: String; Tag, ID: Word; BuddyType: Word; NotAuthorized: Boolean; var Seq: Word);
begin
__CreateCLI_UPDATEBUDDY(Pkt, $09, UIN, Name, SMSNumber, Tag, ID, BuddyType, NotAuthorized, False, Seq);
end;
{Add SSL buddy.}
procedure CreateCLI_ADDBUDDY(Pkt: PRawPkt; UIN, Name, SMSNumber: String; Tag, ID: Word; BuddyType: Word; NotAuthorized: Boolean; var Seq: Word);
begin
__CreateCLI_UPDATEBUDDY(Pkt, $08, UIN, Name, SMSNumber, Tag, ID, BuddyType, NotAuthorized, False, Seq);
end;
{Delete buddy from SSL.}
procedure CreateCLI_DELETEBUDDY(Pkt: PRawPkt; UIN, Name, SMSNumber: String; Tag, ID: Word; BuddyType: Word; NotAuthorized, IsGroup: Boolean; var Seq: Word);
begin
__CreateCLI_UPDATEBUDDY(Pkt, $0A, UIN, Name, SMSNumber, Tag, ID, BuddyType, NotAuthorized, IsGroup, Seq);
end;
{Conver SNAC's numberic representation to string name}
function SnacToStr(Family, SubType: Word): String;
begin
Result := 'unknown';
{CLI}
if (Family = 1) and (SubType = 2) then
Result := 'CLI_READY'
else if (Family = 1) and (SubType = 6) then
Result := 'CLI_RATESREQUEST'
else if (Family = 1) and (SubType = 8) then
Result := 'CLI_ACKRATES'
else if (Family = 1) and (SubType = $E) then
Result := 'CLI_REQINFO'
else if (Family = 1) and (SubType = $17) then
Result := 'CLI_FAMILIES'
else if (Family = 1) and (SubType = $1E) then
Result := 'CLI_SETSTATUS'
else if (Family = 2) and (SubType = $2) then
Result := 'CLI_REQLOCATION'
else if (Family = 2) and (SubType = $4) then
Result := 'CLI_SETUSERINFO'
else if (Family = 3) and (SubType = $2) then
Result := 'CLI_REQBUDDY'
else if (Family = 3) and (SubType = $4) then
Result := 'CLI_ADDCONTACT'
else if (Family = 3) and (SubType = $5) then
Result := 'CLI_REMOVECONTACT'
else if (Family = 4) and (SubType = $2) then
Result := 'CLI_SETICBM'
else if (Family = 4) and (SubType = $4) then
Result := 'CLI_REQICBM'
else if (Family = 4) and (SubType = $6) then
Result := 'CLI_SENDMSG'
else if (Family = 4) and (SubType = $B) then
Result := 'CLI_ACKMSG'
else if (Family = 9) and (SubType = $2) then
Result := 'CLI_REQBOS'
else if (Family = 9) and (SubType = $5) then
Result := 'CLI_ADDVISIBLE'
else if (Family = 9) and (SubType = $6) then
Result := 'CLI_REMVISIBLE'
else if (Family = 9) and (SubType = $7) then
Result := 'CLI_ADDINVISIBLE'
else if (Family = 9) and (SubType = $8) then
Result := 'CLI_REMINVISIBLE'
else if (Family = $13) and (SubType = $2) then
Result := 'CLI_REQUNKNOWN'
else if (Family = $13) and (SubType = $4) then
Result := 'CLI_REQROSTER2'
else if (Family = $13) and (SubType = $5) then
Result := 'CLI_REQROSTER'
else if (Family = $13) and (SubType = $7) then
Result := 'CLI_UNKNOWN1'
else if (Family = $13) and (SubType = $8) then
Result := 'CLI_ADDBUDDY'
else if (Family = $13) and (SubType = $9) then
Result := 'CLI_UPDATEGROUP'
else if (Family = $13) and (SubType = $A) then
Result := 'CLI_DELETEBUDDY'
else if (Family = $13) and (SubType = $11) then
Result := 'CLI_ADDSTART'
else if (Family = $13) and (SubType = $12) then
Result := 'CLI_ADDEND'
else if (Family = $13) and (SubType = $18) then
Result := 'CLI_REQAUTH'
else if (Family = $13) and (SubType = $1A) then
Result := 'CLI_AUTHORIZE'
else if (Family = $15) and (SubType = $2) then
Result := 'CLI_TOICQSRV'
else if (Family = $17) and (SubType = $4) then
Result := 'CLI_REGISTERUSER'
{SRV}
else if (Family = $1) and (SubType = $3) then
Result := 'SRV_FAMILIES'
else if (Family = $1) and (SubType = $7) then
Result := 'SRV_RATES'
else if (Family = $1) and (SubType = $F) then
Result := 'SRV_REPLYINFO'
else if (Family = $1) and (SubType = $13) then
Result := 'SRV_MOTD'
else if (Family = $1) and (SubType = $18) then
Result := 'SRV_FAMILIES2'
else if (Family = $2) and (SubType = $3) then
Result := 'SRV_REPLYLOCATION'
else if (Family = $3) and (SubType = $3) then
Result := 'SRV_REPLYBUDDY'
else if (Family = $3) and (SubType = $B) then
Result := 'SRV_USERONLINE'
else if (Family = $3) and (SubType = $C) then
Result := 'SRV_USEROFFLINE'
else if (Family = $4) and (SubType = $5) then
Result := 'SRV_REPLYICBM'
else if (Family = $4) and (SubType = $7) then
Result := 'SRV_RECVMSG'
else if (Family = $4) and (SubType = $c) then
Result := 'SRV_MSGACK_ADVANCED'
else if (Family = $9) and (SubType = $3) then
Result := 'SRV_REPLYBOS'
else if (Family = $13) and (SubType = $3) then
Result := 'SRV_REPLYUNKNOWN'
else if (Family = $13) and (SubType = $6) then
Result := 'SRV_REPLYROSTER'
else if (Family = $13) and (SubType = $E) then
Result := 'SRV_UPDATEACK'
else if (Family = $13) and (SubType = $F) then
Result := 'SRV_REPLYROSTEROK'
else if (Family = $13) and (SubType = $19) then
Result := 'SRV_AUTHORIZATION_REQUEST'
else if (Family = $13) and (SubType = $1C) then
Result := 'SRV_ADDEDYOU'
else if (Family = $15) and (SubType = $3) then
Result := 'SRV_FROMICQSRV'
else if (Family = $17) and (SubType = $1) then
Result := 'SRV_REGREFUSED'
else if (Family = $17) and (SubType = $5) then
Result := 'SRV_NEWUIN';
end;
{Convert meta command to string representation.}
function SrvMetaToStr(V1, V2: Word): String;
begin
Result := '';
if V1 = 2000 then
case V2 of
1002: Result := 'CLI_METASETGENERAL';
1021: Result := 'CLI_METASETMORE';
1030: Result := 'CLI_METASETABOUT';
1060: Result := 'CLI_SETAUTH';
1070: Result := 'CLI_METASETPASS';
1210: Result := 'CLI_METAREQINFO_SHORT';
1220: Result := 'CLI_METAUNREG';
1232: Result := 'CLI_METAREQINFO';
1331: Result := 'CLI_SEARCHWP';
1375: Result := 'CLI_SEARCHBYPERSINF';
1385: Result := 'CLI_SEARCHBYUIN';
1395: Result := 'CLI_SEARCHBYMAIL';
1870: Result := 'CLI_SEARCHRANDOM';
1880: Result := 'CLI_METASETRANDOM';
2200: Result := 'CLI_REQXML';
5250: Result := 'CLI_SENDSMS';
end
else if V1 = 2010 then
case V2 of
1: Result := 'SRV_SMSREFUSED';
100: Result := 'SRV_METAGENERALDONE';
120: Result := 'SRV_METAMOREDONE';
130: Result := 'SRV_METAABOUTDONE';
150: Result := 'SRV_SMSACK';
160: Result := 'SRV_AUTHDONE';
170: Result := 'SRV_METAPASSDONE';
180: Result := 'SRV_METAUNREG';
200: Result := 'SRV_METAGENERAL';
210: Result := 'SRV_METAWORK';
220: Result := 'SRV_METAMORE';
230: Result := 'SRV_METAABOUT';
235: Result := 'SRV_METAMOREEMAIL';
240: Result := 'SRV_METAINTEREST';
250: Result := 'SRV_METABACKGROUND';
260: Result := 'SRV_METAINFO';
270: Result := 'SRV_META270';
420: Result := 'SRV_METAFOUND';
430: Result := 'SRV_METALAST';
870: Result := 'SRV_METARANDOM';
880: Result := 'SRV_METARANDOMDONE';
end
else if V1 = 60 then
Result := 'CLI_REQOFFLINEMSGS'
else if V1 = 62 then
Result := 'CLI_ACKOFFLINEMSGS'
else if V1 = 65 then
Result := 'SRV_OFFLINEMSG'
else if V1 = 66 then
Result := 'SRV_DONEOFFLINEMSGS';
if Result = '' then
Result := IntToStr(V1) + '/' + IntToStr(V2);
end;
{Convert peer command to string representation.}
function PeerCmdToStr(Cmd: Byte): String;
begin
case Cmd of
$00: Result := 'PEER_FILE_INIT';
$01: Result := 'PEER_INIT_ACK';
$02: Result := 'PEER_MSG';
$03: Result := 'PEER_INIT2';
$06: Result := 'PEER_FILEDATA';
$ff: Result := 'PEER_INIT';
else
Result := '';
end;
end;
{Return Buffer in a string hex dump.}
function DumpPacket(Buffer: Pointer; BufLen: Word): String;
var
S: String;
i, n: Word;
begin
for i := 1 to BufLen do
begin
S := S + IntToHex(PByte(LongWord(Buffer) + i - 1)^, 2) + ' ';
if i mod 16 = 0 then
begin
S := S + ' ';
for n := i - 15 to i do
begin
if (PByte(LongWord(Buffer) + n - 1)^ < $20) or (PByte(LongWord(Buffer) + n - 1)^ > $7F) then
S := S + '.'
else
S := S + PChar(Buffer)[n - 1];
end;
S := S + #13#10;
end;
end;
if BufLen mod 16 <> 0 then
begin
for i := 0 to 15 - (BufLen mod 16) do
S := S + ' ';
S := S + ' ';
for i := BufLen mod 16 downto 1 do
begin
if (PByte(LongWord(Buffer) + BufLen - i)^ < $20) or (PByte(LongWord(Buffer) + BufLen - i)^ > $7F) then
S := S + '.'
else
S := S + PChar(Buffer)[BufLen - i];
end;
end;
Result := S;
end;
{Convert RTF enabled text to plain.}
function Rtf2Txt(const Value: String): String;
var
i: Word;
tag: Boolean;
st: String;
begin
Result := ''; tag := False; st := '';
if Value = '' then Exit;
if Copy(Value, 0, 6) <> '{rtf1' then
begin
Result := Value;
Exit;
end;
for i := 1 to Length(Value) do
begin
if Value[i] in ['', '}', '{'] then
tag := True;
if Value[i + 1] in ['', '}', '{'] then
begin
tag := False;
if st <> '' then
begin
if st = 'par' then Result := Result + #13#10
else if (st[1] = '''') and (Length(st) >= 3) then
begin
Delete(st, 1, 1);
Result := Result + Chr(HexToInt(Copy(st, 0, 2))) + Copy(st, 3, Length(st) - 2);
end
else if ((Pos(' ', st) > 0) or ((Copy(st, 0, 3) = 'par') and (st <> 'pard'))) and (st[Length(st)] <> ';') then
begin
while (Pos(#13, st) > 0) do Delete(st, Pos(#13, st), 1);
while (Pos(#10, st) > 0) do Delete(st, Pos(#10, st), 1);
if Copy(st, 0, 3) = 'par' then
Result := Result + #13#10 + Copy(st, 4, Length(st) - 3)
else
Result := Result + Copy(st, Pos(' ', st) + 1, Length(st) - Pos(' ', st));
end;
end;
st := '';
end;
if tag then
st := st + Value[i + 1];
end;
end;
function StatusToStr(Value: LongWord): String;
begin
{Remove any used flags.}
Value := Value and not S_SHOWIP and not S_WEBAWARE and not S_ALLOWDCONN
and not S_ALLOWDAUTH and not S_ALLOWDLIST;
if Value = S_INVISIBLE then
Result := 'Invisible'
else if Value = S_AWAY then
Result := 'Away'
else if Value = S_NA then
Result := 'N/A'
else if Value = S_OCCUPIED then
Result := 'Occupied'
else if Value = S_DND then
Result := 'DND'
else if Value = S_FFC then
Result := 'FFC'
else
Result := 'Online';
end;
function CountryToStr(Value: Word): String;
var
i: Word;
begin
Result := '';
for i := Low(Countries) to High(Countries) do
if Countries[i].Ident = Value then
begin
Result := Countries[i].Value;
Exit;
end;
end;
function LanguageToStr(Value: Byte): String;
var
i: Byte;
begin
for i := Low(Languages) to High(Languages) do
if Languages[i].Ident = Value then
begin
Result := Languages[i].Value;
Exit;
end;
Result := '';
end;
function OccupationToStr(Value: Word): String;
begin
if (Value >= Low(Occupations)) and (Value <= High(Occupations)) then
Result := Occupations[Value].Value
else
Result := '';
end;
function InterestToStr(Value: Word): String;
begin
if (Value >= Low(Interests)) and (Value <= High(Interests)) then
Result := Interests[Value].Value
else
Result := '';
end;
function PastToStr(Value: Word): String;
var
i: Word;
begin
for i := Low(Pasts) to High(Pasts) do
if Pasts[i].Ident = Value then
begin
Result := Pasts[i].Value;
Exit;
end;
Result := '';
end;
function AffiliationToStr(Value: Word): String;
var
i: Word;
begin
for i := Low(Organizations) to High(Organizations) do
if Organizations[i].Ident = Value then
begin
Result := Organizations[i].Value;
Exit;
end;
Result := '';
end;
{Local raw packet from file.}
function LoadPacketRaw(Pkt: PRawPkt; const FName: String): Boolean;
function TestDigit(Digit: Char): Boolean;
begin
Result := False;
case Digit of
'0'..'9': Result := True;
'A', 'B', 'C', 'D', 'E', 'F',
'a', 'b', 'c', 'd', 'e', 'f': Result := True;
end;
end;
function Convert(Digit: Char): Byte;
begin
Result := 0;
case Digit of
'0'..'9': Result := StrToInt(Digit);
'A', 'a': Result := $A;
'B', 'b': Result := $B;
'C', 'c': Result := $C;
'D', 'd': Result := $D;
'E', 'e': Result := $E;
'F', 'f': Result := $F;
end;
end;
var
F: TextFile;
c, c1: Char;
i: Integer;
begin
PktInitRaw(Pkt);
System.Assign(F, FName); Reset(F);
while not Eof(F) do
begin
for i := 0 to 15 do
begin
Read(F, c);
Read(F, c1);
if TestDigit(c) and TestDigit(c1) then
PktInt(Pkt, Convert(c) shl 4 + Convert(c1), 1);
Read(F, c);
if c = '' then Break;
end;
Readln(F);
end;
System.Close(F);
Result := True;
end;
{Load low packet from file & extract snac header.}
function LoadPacket(Pkt: PRawPkt; const FName: String; var Flap: TFlapHdr; var Snac: TSnacHdr): Boolean;
begin
Result := LoadPacketRaw(Pkt, FName);
pkt^.Len := TFLAPSZ;
GetSnac(Pkt, Snac);
end;
{Checks if the FileName is exists.}
function FileExists(const FileName: String): Boolean;
var
Handle: THandle;
FindData: TWin32FindData;
begin
Handle := FindFirstFile(PChar(FileName), FindData);
Result := (Handle <> INVALID_HANDLE_VALUE) and (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0);
Windows.FindClose(Handle);
end;
{Get size of a file.}
function FileSize(const FName: String): LongWord;
var
FileHandle: THandle;
begin
Result := INVALID_FILE_SIZE;
FileHandle := CreateFile(PChar(FName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_ALWAYS, 0, 0);
if FileHandle = INVALID_HANDLE_VALUE then Exit;
Result := GetFileSize(FileHandle, nil);
CloseHandle(FileHandle);
end;
{Add some Text to FName file.}
procedure LogText(const FName, Text: String);
var
F: TextFile;
begin
if not FileExists(FName) then
begin
Assign(F, FName);
{$I-}
ReWrite(F);
if IOResult <> 0 then
Exit;
{$I+}
CloseFile(F);
end;
Assign(F, FName);
{$I-}
Append(F);
if IOResult <> 0 then
Exit;
Writeln(F, Text);
{$I+}
CloseFile(F);
end;
{Overloaded procedure equal to ShowMessage() from 'Dialogs' unit}
procedure ShowMessage(const Value: String); overload;
begin
MessageBox(0, PChar(Value), 'Message', 0);
end;
procedure ShowMessage(Value: LongWord); overload;
begin
MessageBox(0, PChar(IntToStr(Value)), 'Message', 0);
end;
//Extract the name from the following string: 'AA=BB', where AA is name
function ExtractName(const Value: String): String;
var
i: Word;
begin
Result := '';
i := Pos('=', Value);
if i = 0 then
Exit;
Result := Copy(Value, 0, i - 1);
end;
//Extract the value from the following string: 'AA=BB', where BB is value
function ExtractValue(const Value: String): String;
var
i: Word;
begin
Result := '';
i := Pos('=', Value);
if i = 0 then
Exit;
Result := Copy(Value, i + 1, Length(Value) - i);
end;
{Convert string from UTF-8 format into ASCII}
function UTF8ToStr(Value: String): String;
var
buffer: Pointer;
BufLen: LongWord;
begin
BufLen := Length(Value) + 4;
GetMem(buffer, BufLen);
FillChar(buffer^, BufLen, 0);
MultiByteToWideChar(CP_UTF8, 0, @Value[1], BufLen - 4, buffer, BufLen);
Result := WideCharToString(buffer);
FreeMem(buffer, BufLen);
end;
{Convert string from UTF-8 format mixed with standart ASCII symbols($00..$7f)}
function UTF8ToStrSmart(Value: String): String;
var
Digit: String;
i: Word;
HByte: Byte;
Len: Byte;
begin
Result := '';
Len := 0;
if Value = '' then Exit;
for i := 1 to Length(Value) do
begin
if Len > 0 then
begin
Digit := Digit + Value[i];
Dec(Len);
if Len = 0 then
Result := Result + UTF8ToStr(Digit);
end else
begin
HByte := Ord(Value[i]);
if HByte in [$00..$7f] then //Standart ASCII chars
Result := Result + Value[i]
else begin
//Get length of UTF-8 char
if HByte and $FC = $FC then
Len := 6
else if HByte and $F8 = $F8 then
Len := 5
else if HByte and $F0 = $F0 then
Len := 4
else if HByte and $E0 = $E0 then
Len := 3
else if HByte and $C0 = $C0 then
Len := 2
else begin
Result := Result + Value[i];
Continue;
end;
Dec(Len);
Digit := Value[i];
end;
end;
end;
end;
{Get an XML entry.}
function GetXMLEntry(const Tag, Msg: String): String;
var
p1, p2: Word;
begin
p1 := Pos('<' + Tag + '>', Msg);
p2 := Pos('</' + Tag + '>', Msg);
Result := Copy(Msg, p1 + Length(Tag) + 2, p2 - p1 - Length(Tag) - 2);
end;
{SMS functions}
{Convert string to UTF8 format}
function StrToUTF8(Value: String): String;
var
buffer: Pointer;
BufLen: LongWord;
lpBuf: Pointer;
begin
BufLen := Length(Value) * 2 + 4;
GetMem(buffer, BufLen); FillChar(buffer^, BufLen, 0);
GetMem(lpBuf, BufLen); FillChar(lpBuf^, BufLen, 0);
StringToWideChar(Value, buffer, BufLen);
WideCharToMultiByte(CP_UTF8, 0, buffer, -1, lpBuf, BufLen, nil, nil);
FreeMem(buffer, BufLen);
Result := PChar(lpBuf);
FreeMem(lpBuf, BufLen);
end;
{Get current time in format like 'Mon, 19 Nov 2001 08:23:38 GMT'}
function STime: String;
var
buf: array[0..15] of Char;
recv_bytes: Integer;
SysTime: TSystemTime;
begin
GetSystemTime(SysTime);
recv_bytes := GetTimeFormat(LANG_ENGLISH, TIME_FORCE24HOURFORMAT,
@SysTime, PChar('HH:mm:ss'), @buf, SizeOf(buf));
Result := Copy(buf, 0, recv_bytes);
end;
{Get current time in format like 'Mon, 19 Nov 2001 08:23:38 GMT'}
function GetSMSTime: String;
function STime: String;
var
buf: array[0..15] of Char;
recv_bytes: Integer;
SysTime: TSystemTime;
begin
GetSystemTime(SysTime);
recv_bytes := GetTimeFormat(LANG_ENGLISH, TIME_FORCE24HOURFORMAT,
@SysTime, PChar('HH:mm:ss'), @buf, SizeOf(buf));
Result := Copy(buf, 0, recv_bytes);
end;
function SDate: String;
var
buf: array[0..15] of Char;
recv_bytes: Integer;
SysTime: TSystemTime;
begin
GetSystemTime(SysTime);
recv_bytes := GetDateFormat(LANG_ENGLISH, 0,
@SysTime, 'dd MMM yyyy', @buf, SizeOf(buf));
Result := Copy(buf, 0, recv_bytes);
end;
begin
Result := SDate + ' ' + STime + ' GMT';
end;
const
client_check_data: PChar =
'As part of this software beta version Mirabilis is ' +
'granting a limited access to the ICQ network, ' +
'servers, directories, listings, information and databases ("' +
'ICQ Services and Information"). The ' +
'ICQ Service and Information may databases ("' +
'ICQ Services and Information"). The ' +
'ICQ Service and Information may'#0;
{Decrypt peer packet.}
function DecryptPak(Pak: Pointer; Size: LongWord; Ver: Byte): Boolean;
var
hex, key, B1, M1, check: LongWord;
i: Word;
X1, X2, X3: Byte;
begin
if Ver > 6 then
begin
Pak := Ptr(LongWord(Pak) + 1);
Dec(Size);
end;
{ get checkcode }
check := PLongWord(pak)^;
{ primary decryption }
key := $67657268 * size + check;
i := 4;
while i < Integer((size + 3) shr 2) do
begin
hex := key + Ord(client_check_data[i and $FF]);
PLongWord(LongWord(pak) + i)^ := PLongWord(LongWord(pak) + i)^ xor hex;
Inc(i, 4);
end;
B1 := (PByte(LongWord(pak) + 4)^ shl 24) or (PByte(LongWord(pak) + 6)^ shl 16) or (PByte(LongWord(pak) + 4)^ shl 8) or (PByte(LongWord(pak) + 6)^ shl 0);
{ special decryption }
B1 := B1 xor check;
{ validate packet }
M1 := (B1 shr 24) and $FF;
if (M1 < 10) or (M1 >= size) then
begin
Result := False;
Exit;
end;
X1 := PByte(LongWord(pak) + M1)^ xor $FF;
if (((B1 shr 16) and $FF) <> X1) then
begin
Result := False;
Exit;
end;
X2 := ((B1 shr 8) and $FF);
if (X2 < 220) then
begin
X3 := Ord(client_check_data[X2]) xor $FF;
if (B1 and $FF) <> X3 then
begin
Result := False;
Exit;
end;
end;
Result := True;
end;
{Encrypt peer packet.}
procedure EncryptPak(Pak: Pointer; Size: LongWord; Ver: Byte);
var
B1, M1, check, hex, key: LongWord;
i: Word;
X1, X2, X3, at: Byte;
p: PByte;
begin
p := Pak;
size := Size;
if (Ver > 6) then
begin
Inc(p);
Dec(Size);
end;
{ calculate verification data }
if size < 255 then
M1 := (Random(High(Word)) mod (Integer(size - 10))) + 10
else
M1 := (Random(High(Word)) mod 245) + 10;
X1 := PByte(LongWord(p) + M1)^ xor $FF;
X2 := Random(High(Word)) mod 220;
X3 := Ord(client_check_data[X2]) xor $FF;
B1 := (PByte(LongWord(p) + 4)^ shl 24) or (PByte(LongWord(p) + 6)^ shl 16) or
(PByte(LongWord(p) + 4)^ shl 8) or (PByte(LongWord(p) + 6)^);
{ calculate checkcode }
check := (M1 shl 24) or (X1 shl 16) or (X2 shl 8) or X3;
check := check xor B1;
{ main XOR key }
key := $67657268 * size + check;
{ XORing the actual data }
i := 0;
while i < ((size + 3) div 4) do
begin
hex := key + Ord(client_check_data[i and $FF]);
PLongWord(LongWord(p) + i)^ := PLongWord(LongWord(p) + i)^ xor hex;
Inc(i, 4);
end;
{ storing the checkcode }
if Ver > 6 then at := 1 else at := 0;
PLongWord(LongWord(pak) + at)^ := check;
end;
{This packet is sent during direct connection initialization between two ICQ clients.
It is sent by the originator of the connection to start the handshake and by the
receiver directly after it has sent the PEER_ACK packet as a reply to the originator's
PEER_INIT.}
procedure CreatePEER_INIT(Pkt: PRawPkt; Cookie, DestUIN, SrcUIN, SrcPort, SrcIPExt, SrcIPInt: LongWord; ProxyType: TProxyType);
begin
PktInitRaw(Pkt);
PktInt(Pkt, $ff, 1); //The command: connect.
PktInt(Pkt, $0800, 2); //The peer-to-peer version this packet uses.
PktInt(Pkt, $2b00, 2); //The length of the following data in bytes.
PktLInt(Pkt, DestUIN, 4); //The UIN this packet is sent to.
PktInt(Pkt, $0000, 2); //Unknown: empty.
PktLInt(Pkt, SrcPort, 4); //The port the sender listens on.
PktLInt(Pkt, SrcUIN, 4); //The UIN of the sender.
PktLInt(Pkt, SrcIPExt, 4); //The IP of the sender as the server sees it.
PktLInt(Pkt, SrcIPInt, 4); //The local IP of the sender.
if ProxyType = P_NONE then
PktInt(Pkt, $04, 1) //TCP connection flags: dirrect connection
else
PktInt(Pkt, $02, 1); //TCP connection flags: 02 - SOCKS4/5 proxy
PktLInt(Pkt, SrcPort, 4); //The sender's "other" port.
PktInt(Pkt, Cookie, 4); //The connection cookie the server gave for this pair of UINs
PktInt(Pkt, $50000000, 4); //Unknown: 0x50 = 80.
PktInt(Pkt, $03000000, 4); //Unknown: 0x3 = 3.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
end;
{This is an additional packet in the peer-to-peer handshake. The purpose is still
unknown. It is sent by the originator of the connection after he has acknowledged
the peer's PEER_INIT and by the peer as a reply to the originator's PEER_INIT2.}
procedure CreatePEER_INIT2(Pkt: PRawPkt; Ack: Boolean);
begin
PktInitRaw(Pkt);
PktInt(Pkt, $03, 1); //The command: the last connect package
PktInt(Pkt, $0a000000, 4); //Unknown: 0xa = 10.
PktInt(Pkt, $01000000, 4); //Unknown: 0x1 = 1.
if Ack then //
PktInt(Pkt, $01000000, 4) //Unknown. Use 01 00 00 00 = 0x1 = 1 for incoming,
else //
PktInt(Pkt, $00000000, 4); //0 for outgoing connections.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
if Ack then //
PktInt(Pkt, $01000400, 4) //Unknown. Use 01 00 04 00 = 0x40001 for incoming
else //
PktInt(Pkt, $00000000, 4); //and 0 for outgoing connections.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
if Ack then //
PktInt(Pkt, $00000000, 4) //Unknown. Use 0 on incoming,
else //
PktInt(Pkt, $01000400, 4); //but 01 00 04 00 = 0x4001 for outgoing connections.
end;
{Acknowledges the receipt of a PEER_INIT packet.}
procedure CreatePEER_ACK(Pkt: PRawPkt);
begin
PktInitRaw(Pkt);
PktInt(Pkt, $01000000, 4); //The command: acknowlegde the PEER_INIT
end;
{Basic header of outgoing PEER packet.}
procedure CreatePEER_HDR(Pkt: PRawPkt; Cmd, SubCmd, Seq: Word; Accept: Boolean);
begin
PktInitRaw(Pkt); //Init
PktInt(Pkt, $02, 1); //The command: send a message.
PktInt(Pkt, $00000000, 4); //The checksum of this packet.
PktInt(Pkt, Cmd, 2); //Message common type
PktInt(Pkt, $0e00, 2); //Unknown: 0xe = 14.
PktLInt(Pkt, Seq, 2); //Our sequence number.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
PktInt(Pkt, $00000000, 4); //Unknown: empty.
PktInt(Pkt, SubCmd, 2); //The message type: message
if Accept then
PktInt(Pkt, $0000, 2) //0x0000 - accept
else
PktInt(Pkt, $0100, 2); //0x0100 - decline
end;
{Send a message to peer.}
function CreatePEER_MSG(Pkt: PRawPkt; const Msg: String; RTFFormat: Boolean; var Seq: Word): Word;
const
StrGuid: String = '{97B12751-243C-4334-AD22-D6ABF73F1492}';
begin
CreatePEER_HDR(Pkt, $ee07, $0100, Seq, True);
PktInt(Pkt, $0000, 2); //Our status.
PktLNTS(Pkt, Msg); //Finally the message.
PktInt(Pkt, $00000000, 4); //The foreground the client is expected to use.
PktInt(Pkt, $ffffff00, 4); //The background color the client is expected to show the message with.
if RTFFormat then
begin
PktLInt(Pkt, Length(StrGuid), 4); //This is a little-endian string length of the following GUID. This is only present in real messages sent by the latest 2001b client build 3659.
PktStr(Pkt, StrGuid); //This GUID seems to indicate that the client is capable of handling Multibyte Wide Character Strings as messages. Only present in real messages sent by build 3659 2001b clients.}
end;
EncryptPak(Pkt, Pkt^.Len, 8); //Encrypt packet
Result := Seq; Inc(Seq); //Inc Seq
end;
{Ack}
procedure CreatePEER_MSGACK(Pkt: PRawPkt; Seq: Word);
begin
CreatePEER_HDR(Pkt, $da07, $0100, Seq, True);
PktInt(Pkt, $0000, 2); //Our status
PktInt(Pkt, $0100, 2); //Msg len = 1, Value = 0
PktInt(Pkt, $00, 1); //Msg null terminator
PktInt(Pkt, $00000000, 4); //The foreground the client is expected to use.
PktInt(Pkt, $ffffff00, 4); //The background color the client is expected to show the message with.
EncryptPak(Pkt, Pkt^.Len, 8); //Encrypt packet
end;
{Response on auto-away msg request.}
procedure CreatePEER_AUTOMSG_ACK(Pkt: PRawPkt; Answer: String; Status, Seq: Word);
begin
CreatePEER_HDR(Pkt, $da07, Swap16(Status), Seq, True);
PktInt(Pkt, $0000, 2); //Our status
PktLNTS(Pkt, Answer);
EncryptPak(Pkt, Pkt^.Len, 8); //Encrypt packet
end;
{Sends contacts to user.}
function CreatePEER_CONTACTS(Pkt: PRawPkt; Contacts: TStringList; var Seq: Word): Word;
const
StrCmd: String = 'Contacts';
var
S: String;
begin
CreatePEER_HDR(Pkt, $ee07, $1a00, Seq, True);
PktInt(Pkt, $0000, 2); //Our status.
PktInt(Pkt, $0100, 2); //Message length: 2
PktInt(Pkt, $00, 1); //Null terminator
PktInt(Pkt, $2d00, 2); //Following length
PktAddArrBuf(Pkt, @ContactsSignature, 16); //14 unknown bytes
PktInt(Pkt, $0000, 2); //Possible command: send contacts
PktLInt(Pkt, Length(StrCmd), 4); //Length of the text command
PktStr(Pkt, StrCmd); //Text command
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $0001, 2); //Unknown: 0x01
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00, 1); //Unknown: empty
S := MakeContactsStr(Contacts); //Create text list from string list
PktLInt(Pkt, Length(S) + 4, 4); //Length of the following data
PktDWStr(Pkt, S); //Length of the following string
EncryptPak(Pkt, Pkt^.Len, 8); //Encrypt packet
Result := Seq; Inc(Seq); //Inc Seq
end;
function CreatePEER_CONTACTREQ(Pkt: PRawPkt; const Reason: String; var Seq: Word): Word;
const
StrCmd: String = 'Request For Contacts';
begin
CreatePEER_HDR(Pkt, $ee07, $1a00, Seq, True);
PktInt(Pkt, $0000, 2); //Our status.
PktInt(Pkt, $0100, 2); //Message length: 2
PktInt(Pkt, $00, 1); //Null terminator
PktInt(Pkt, $3900, 2); //Following length
PktAddArrBuf(Pkt, @ContactsSignature, 16); //16 unknown bytes
PktInt(Pkt, $0200, 2); //Possible command requesting contacts
PktLInt(Pkt, Length(StrCmd), 4); //Length of the text command
PktStr(Pkt, StrCmd); //Text command
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $0001, 2); //Unknown: 0x01
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00000000, 4); //Unknown: empty
PktInt(Pkt, $00, 1); //Unknown: empty
PktLInt(Pkt, Length(Reason) + 4, 4); //Length of the following data
PktLInt(Pkt, Length(Reason), 4); //Length of the following string
PktStr(Pkt, Reason); //Following string
EncryptPak(Pkt, Pkt^.Len, 8); //Encrypt packet
Result := Seq; Inc(Seq); //Inc Seq
end;
function CreatePEER_FILEINIT(Pkt: PRawPkt; Response: Boolean; FileDescription, FileName: String; Port: Word; FileLength: LongWord; var Seq: Word; Reason: String; Accept: Boolean): Word;
const
StrCmd = 'File';
var
lpkt: TRawPkt;
begin
CreatePEER_HDR(Pkt, $da07, $1a00, Seq, Accept);
if Accept then Reason := '';
PktInt(Pkt, $0000, 2); //Status
if Length(Reason) = 0 then
begin
PktInt(Pkt, $01, 1); //Flags
PktInt(Pkt, $0000, 2); //Unknown
end else
begin
PktLInt(Pkt, Length(Reason) + 1, 2);
PktStr(Pkt, Reason);
PktInt(Pkt, $00, 1);
end;
PktInitRaw(@lpkt); //Init new packet for the feature concatination
PktAddArrBuf(@lpkt, @FileSignature, 16); //Signature
PktInt(@lpkt, $0000, 2); //Unknown
PktLInt(@lpkt, Length(StrCmd), 4); //Length of the text command
PktStr(@lpkt, StrCmd); //Text command
PktInt(@lpkt, $00000100, 4); //Unknown
PktInt(@lpkt, $00010000, 4); //Unknown
PktInt(@lpkt, $00000000, 4); //Unknown
PktInt(@lpkt, $0000, 2); //Unknown
PktInt(@lpkt, $00, 1); //Unknown
PktLInt(Pkt, lpkt.Len, 2); //Length of the message
PktAddArrBuf(Pkt, @lpkt, lpkt.Len); //Implode packets
PktInitRaw(@lpkt); //Init new packet for the feature concatination
PktLInt(@lpkt, Length(FileDescription), 4); //Length of files description
PktStr(@lpkt, FileDescription); //Files description
PktInt(@lpkt, Port, 2); //Port
if not Response then
PktInt(@lpkt, $5401, 2) //Seq
else
PktInt(@lpkt, $0000, 2); //Seq
PktLInt(@lpkt, Length(FileName) + 2, 2); //Length of files description
PktStr(@lpkt, FileName); //Files description
PktInt(@lpkt, $0000, 2); //Null terminator
PktLInt(@lpkt, FileLength, 4); //Filelength
PktLInt(@lpkt, Port, 4); //Port
PktLInt(Pkt, lpkt.Len, 4); //Length of the following data
PktAddArrBuf(Pkt, @lpkt, lpkt.Len); //Implode packets
EncryptPak(Pkt, Pkt^.Len, 8); //Encrypt packet
Result := Seq; //Inc Seq
end;
{This packet is a response to the incoming file transfer. It is sent as
a response to the PEER_FILE_INIT command.}
procedure CreatePEER_FILEINITACK(Pkt: PRawPkt; Speed: LongWord; Nick: String);
begin
PktInitRaw(Pkt); //Initialize packet
PktInt(Pkt, $01, 1); //The command: PEER_FILE_INITACK
PktLInt(Pkt, Speed, 4); //The receiver's speed. See PEER_FILE_INIT.
PktLNTS(Pkt, Nick); //The receiver's nick.
end;
{The init packet sent within a new connection to the receiver given port
to initiate the file transfer. Note: the new connection is started with a
PEER_INIT/PEER_INITACK/PEER_INITACK2 sequence. Note: This is v6 of the
protocol.}
procedure CreatePEER_FILE_INIT2(Pkt: PRawPkt; Count, Bytes, Speed: LongWord);
begin
PktInitRaw(Pkt); //Initialize packet
PktInt(Pkt, $03, 1); //The command: PEER_FILE_INITACK2
PktInt(Pkt, $00000000, 4); //Unknown: empty.
PktLInt(Pkt, Bytes, 4); //Total bytes of all files to sent.
PktLInt(Pkt, Speed, 4); //The sender's speed. See PEER_FILE_INIT.
PktLInt(Pkt, Count, 4); //Total number of files to be sent.
end;
{Create HTTP header.}
function CreateHTTP_Header(Method: String; URL, Host: String; DataLen: LongWord): String;
begin
Result := Method + ' ' + URL + ' HTTP/1.1' + #13#10 +
'user-agent: Mozilla/4.08 [en] (WinNT; U ;Nav)' + #13#10;
if DataLen > 0 then
Result := Result + 'content-length: ' + IntToStr(DataLen) + #13#10;
Result := Result +
'cache-control: no-store, no-cache' + #13#10 +
'host: ' + Host + #13#10 +
'connection: close' + #13#10 +
'pragma: no-cache' + #13#10#13#10;
end;
{Write data headers in http proto.}
procedure CreateHTTP_DATA(Pkt: PRawPkt; PType: Word; Data: Pointer; DataLen: LongWord);
var
lpkt: TRawPkt;
begin
PktInitRaw(pkt);
PktInitRaw(@lpkt);
PktInt(@lpkt, $0443, 2); //Version
PktInt(@lpkt, PType, 2); //Packet type
PktInt(@lpkt, $00000000, 4); //Unknown
PktInt(@lpkt, $00000001, 4); //Unknown
PktAddArrBuf(@lpkt, Data, DataLen); //Packet specific data
PktInt(pkt, lpkt.Len, 2); //Length of the following data
PktAddArrBuf(pkt, @lpkt, lpkt.Len); //Implode packets
end;
{First packet sent to proxy.}
function CreateHTTP_INIT: String;
begin
Result := CreateHTTP_Header('GET', 'http://http.proxy.icq.com/hello', 'http.proxy.icq.com', 0);
end;
{Packet sent after packet was received from server.}
function CreateHTTP_RECV(Host, SID: String): String;
begin
Result := CreateHTTP_Header('GET', 'http://' + Host + '/monitor?sid=' + SID, Host, 0);
end;
{Packet send as a response on HTTP_HELLO, ptype = 2.}
procedure CreateHTTP_LOGIN(Pkt: PRawPkt; Host: String; Port: Word);
var
lpkt: TRawPkt;
begin
PktInitRaw(@lpkt);
PktWStr(@lpkt, Host); //ICQ server
PktInt(@lpkt, Port, 2); //Port
CreateHTTP_DATA(Pkt, $0003, @lpkt, lpkt.Len);
end;
{Xorkeygen tabs}
const
TAB0: array[0..63] of LongWord =
($00820200, $00020000, $80800000, $80820200,
$00800000, $80020200, $80020000, $80800000,
$80020200, $00820200, $00820000, $80000200,
$80800200, $00800000, $00000000, $80020000,
$00020000, $80000000, $00800200, $00020200,
$80820200, $00820000, $80000200, $00800200,
$80000000, $00000200, $00020200, $80820000,
$00000200, $80800200, $80820000, $00000000,
$00000000, $80820200, $00800200, $80020000,
$00820200, $00020000, $80000200, $00800200,
$80820000, $00000200, $00020200, $80800000,
$80020200, $80000000, $80800000, $00820000,
$80820200, $00020200, $00820000, $80800200,
$00800000, $80000200, $80020000, $00000000,
$00020000, $00800000, $80800200, $00820200,
$80000000, $80820000, $00000200, $80020200);
TAB1: array[0..63] of LongWord =
($10042004, $00000000, $00042000, $10040000,
$10000004, $00002004, $10002000, $00042000,
$00002000, $10040004, $00000004, $10002000,
$00040004, $10042000, $10040000, $00000004,
$00040000, $10002004, $10040004, $00002000,
$00042004, $10000000, $00000000, $00040004,
$10002004, $00042004, $10042000, $10000004,
$10000000, $00040000, $00002004, $10042004,
$00040004, $10042000, $10002000, $00042004,
$10042004, $00040004, $10000004, $00000000,
$10000000, $00002004, $00040000, $10040004,
$00002000, $10000000, $00042004, $10002004,
$10042000, $00002000, $00000000, $10000004,
$00000004, $10042004, $00042000, $10040000,
$10040004, $00040000, $00002004, $10002000,
$10002004, $00000004, $10040000, $00042000);
TAB2: array[0..63] of LongWord =
($41000000, $01010040, $00000040, $41000040,
$40010000, $01000000, $41000040, $00010040,
$01000040, $00010000, $01010000, $40000000,
$41010040, $40000040, $40000000, $41010000,
$00000000, $40010000, $01010040, $00000040,
$40000040, $41010040, $00010000, $41000000,
$41010000, $01000040, $40010040, $01010000,
$00010040, $00000000, $01000000, $40010040,
$01010040, $00000040, $40000000, $00010000,
$40000040, $40010000, $01010000, $41000040,
$00000000, $01010040, $00010040, $41010000,
$40010000, $01000000, $41010040, $40000000,
$40010040, $41000000, $01000000, $41010040,
$00010000, $01000040, $41000040, $00010040,
$01000040, $00000000, $41010000, $40000040,
$41000000, $40010040, $00000040, $01010000);
TAB3: array[0..63] of LongWord =
($00100402, $04000400, $00000002, $04100402,
$00000000, $04100000, $04000402, $00100002,
$04100400, $04000002, $04000000, $00000402,
$04000002, $00100402, $00100000, $04000000,
$04100002, $00100400, $00000400, $00000002,
$00100400, $04000402, $04100000, $00000400,
$00000402, $00000000, $00100002, $04100400,
$04000400, $04100002, $04100402, $00100000,
$04100002, $00000402, $00100000, $04000002,
$00100400, $04000400, $00000002, $04100000,
$04000402, $00000000, $00000400, $00100002,
$00000000, $04100002, $04100400, $00000400,
$04000000, $04100402, $00100402, $00100000,
$04100402, $00000002, $04000400, $00100402,
$00100002, $00100400, $04100000, $04000402,
$00000402, $04000000, $04000002, $04100400);
TAB4: array[0..63] of LongWord =
($02000000, $00004000, $00000100, $02004108,
$02004008, $02000100, $00004108, $02004000,
$00004000, $00000008, $02000008, $00004100,
$02000108, $02004008, $02004100, $00000000,
$00004100, $02000000, $00004008, $00000108,
$02000100, $00004108, $00000000, $02000008,
$00000008, $02000108, $02004108, $00004008,
$02004000, $00000100, $00000108, $02004100,
$02004100, $02000108, $00004008, $02004000,
$00004000, $00000008, $02000008, $02000100,
$02000000, $00004100, $02004108, $00000000,
$00004108, $02000000, $00000100, $00004008,
$02000108, $00000100, $00000000, $02004108,
$02004008, $02004100, $00000108, $00004000,
$00004100, $02004008, $02000100, $00000108,
$00000008, $00004108, $02004000, $02000008);
TAB5: array[0..63] of LongWord =
($20000010, $00080010, $00000000, $20080800,
$00080010, $00000800, $20000810, $00080000,
$00000810, $20080810, $00080800, $20000000,
$20000800, $20000010, $20080000, $00080810,
$00080000, $20000810, $20080010, $00000000,
$00000800, $00000010, $20080800, $20080010,
$20080810, $20080000, $20000000, $00000810,
$00000010, $00080800, $00080810, $20000800,
$00000810, $20000000, $20000800, $00080810,
$20080800, $00080010, $00000000, $20000800,
$20000000, $00000800, $20080010, $00080000,
$00080010, $20080810, $00080800, $00000010,
$20080810, $00080800, $00080000, $20000810,
$20000010, $20080000, $00080810, $00000000,
$00000800, $20000010, $20000810, $20080800,
$20080000, $00000810, $00000010, $20080010);
TAB6: array[0..63] of LongWord =
($00001000, $00000080, $00400080, $00400001,
$00401081, $00001001, $00001080, $00000000,
$00400000, $00400081, $00000081, $00401000,
$00000001, $00401080, $00401000, $00000081,
$00400081, $00001000, $00001001, $00401081,
$00000000, $00400080, $00400001, $00001080,
$00401001, $00001081, $00401080, $00000001,
$00001081, $00401001, $00000080, $00400000,
$00001081, $00401000, $00401001, $00000081,
$00001000, $00000080, $00400000, $00401001,
$00400081, $00001081, $00001080, $00000000,
$00000080, $00400001, $00000001, $00400080,
$00000000, $00400081, $00400080, $00001080,
$00000081, $00001000, $00401081, $00400000,
$00401080, $00000001, $00001001, $00401081,
$00400001, $00401080, $00401000, $00001001);
TAB7: array[0..63] of LongWord =
($08200020, $08208000, $00008020, $00000000,
$08008000, $00200020, $08200000, $08208020,
$00000020, $08000000, $00208000, $00008020,
$00208020, $08008020, $08000020, $08200000,
$00008000, $00208020, $00200020, $08008000,
$08208020, $08000020, $00000000, $00208000,
$08000000, $00200000, $08008020, $08200020,
$00200000, $00008000, $08208000, $00000020,
$00200000, $00008000, $08000020, $08208020,
$00008020, $08000000, $00000000, $00208000,
$08200020, $08008020, $08008000, $00200020,
$08208000, $00000020, $00200020, $08008000,
$08208020, $00200000, $08200000, $08000020,
$00208000, $00008020, $08008020, $08200000,
$00000020, $08208000, $00208020, $00000000,
$08000000, $08200020, $00008000, $00208020);
TAB8: array[0..63] of LongWord =
($00000000, $00000010, $20000000, $20000010,
$00010000, $00010010, $20010000, $20010010,
$00000800, $00000810, $20000800, $20000810,
$00010800, $00010810, $20010800, $20010810,
$00000020, $00000030, $20000020, $20000030,
$00010020, $00010030, $20010020, $20010030,
$00000820, $00000830, $20000820, $20000830,
$00010820, $00010830, $20010820, $20010830,
$00080000, $00080010, $20080000, $20080010,
$00090000, $00090010, $20090000, $20090010,
$00080800, $00080810, $20080800, $20080810,
$00090800, $00090810, $20090800, $20090810,
$00080020, $00080030, $20080020, $20080030,
$00090020, $00090030, $20090020, $20090030,
$00080820, $00080830, $20080820, $20080830,
$00090820, $00090830, $20090820, $20090830);
TAB9: array[0..63] of LongWord =
($00000000, $02000000, $00002000, $02002000,
$00200000, $02200000, $00202000, $02202000,
$00000004, $02000004, $00002004, $02002004,
$00200004, $02200004, $00202004, $02202004,
$00000400, $02000400, $00002400, $02002400,
$00200400, $02200400, $00202400, $02202400,
$00000404, $02000404, $00002404, $02002404,
$00200404, $02200404, $00202404, $02202404,
$10000000, $12000000, $10002000, $12002000,
$10200000, $12200000, $10202000, $12202000,
$10000004, $12000004, $10002004, $12002004,
$10200004, $12200004, $10202004, $12202004,
$10000400, $12000400, $10002400, $12002400,
$10200400, $12200400, $10202400, $12202400,
$10000404, $12000404, $10002404, $12002404,
$10200404, $12200404, $10202404, $12202404);
TABA: array[0..63] of LongWord =
($00000000, $00000001, $00040000, $00040001,
$01000000, $01000001, $01040000, $01040001,
$00000002, $00000003, $00040002, $00040003,
$01000002, $01000003, $01040002, $01040003,
$00000200, $00000201, $00040200, $00040201,
$01000200, $01000201, $01040200, $01040201,
$00000202, $00000203, $00040202, $00040203,
$01000202, $01000203, $01040202, $01040203,
$08000000, $08000001, $08040000, $08040001,
$09000000, $09000001, $09040000, $09040001,
$08000002, $08000003, $08040002, $08040003,
$09000002, $09000003, $09040002, $09040003,
$08000200, $08000201, $08040200, $08040201,
$09000200, $09000201, $09040200, $09040201,
$08000202, $08000203, $08040202, $08040203,
$09000202, $09000203, $09040202, $09040203);
TABB: array[0..63] of LongWord =
($00000000, $00100000, $00000100, $00100100,
$00000008, $00100008, $00000108, $00100108,
$00001000, $00101000, $00001100, $00101100,
$00001008, $00101008, $00001108, $00101108,
$04000000, $04100000, $04000100, $04100100,
$04000008, $04100008, $04000108, $04100108,
$04001000, $04101000, $04001100, $04101100,
$04001008, $04101008, $04001108, $04101108,
$00020000, $00120000, $00020100, $00120100,
$00020008, $00120008, $00020108, $00120108,
$00021000, $00121000, $00021100, $00121100,
$00021008, $00121008, $00021108, $00121108,
$04020000, $04120000, $04020100, $04120100,
$04020008, $04120008, $04020108, $04120108,
$04021000, $04121000, $04021100, $04121100,
$04021008, $04121008, $04021108, $04121108);
TABC: array[0..63] of LongWord =
($00000000, $10000000, $00010000, $10010000,
$00000004, $10000004, $00010004, $10010004,
$20000000, $30000000, $20010000, $30010000,
$20000004, $30000004, $20010004, $30010004,
$00100000, $10100000, $00110000, $10110000,
$00100004, $10100004, $00110004, $10110004,
$20100000, $30100000, $20110000, $30110000,
$20100004, $30100004, $20110004, $30110004,
$00001000, $10001000, $00011000, $10011000,
$00001004, $10001004, $00011004, $10011004,
$20001000, $30001000, $20011000, $30011000,
$20001004, $30001004, $20011004, $30011004,
$00101000, $10101000, $00111000, $10111000,
$00101004, $10101004, $00111004, $10111004,
$20101000, $30101000, $20111000, $30111000,
$20101004, $30101004, $20111004, $30111004);
TABD: array[0..63] of LongWord =
($00000000, $08000000, $00000008, $08000008,
$00000400, $08000400, $00000408, $08000408,
$00020000, $08020000, $00020008, $08020008,
$00020400, $08020400, $00020408, $08020408,
$00000001, $08000001, $00000009, $08000009,
$00000401, $08000401, $00000409, $08000409,
$00020001, $08020001, $00020009, $08020009,
$00020401, $08020401, $00020409, $08020409,
$02000000, $0A000000, $02000008, $0A000008,
$02000400, $0A000400, $02000408, $0A000408,
$02020000, $0A020000, $02020008, $0A020008,
$02020400, $0A020400, $02020408, $0A020408,
$02000001, $0A000001, $02000009, $0A000009,
$02000401, $0A000401, $02000409, $0A000409,
$02020001, $0A020001, $02020009, $0A020009,
$02020401, $0A020401, $02020409, $0A020409);
TABE: array[0..63] of LongWord =
($00000000, $00000100, $00080000, $00080100,
$01000000, $01000100, $01080000, $01080100,
$00000010, $00000110, $00080010, $00080110,
$01000010, $01000110, $01080010, $01080110,
$00200000, $00200100, $00280000, $00280100,
$01200000, $01200100, $01280000, $01280100,
$00200010, $00200110, $00280010, $00280110,
$01200010, $01200110, $01280010, $01280110,
$00000200, $00000300, $00080200, $00080300,
$01000200, $01000300, $01080200, $01080300,
$00000210, $00000310, $00080210, $00080310,
$01000210, $01000310, $01080210, $01080310,
$00200200, $00200300, $00280200, $00280300,
$01200200, $01200300, $01280200, $01280300,
$00200210, $00200310, $00280210, $00280310,
$01200210, $01200310, $01280210, $01280310);
TABF: array[0..63] of LongWord =
($00000000, $04000000, $00040000, $04040000,
$00000002, $04000002, $00040002, $04040002,
$00002000, $04002000, $00042000, $04042000,
$00002002, $04002002, $00042002, $04042002,
$00000020, $04000020, $00040020, $04040020,
$00000022, $04000022, $00040022, $04040022,
$00002020, $04002020, $00042020, $04042020,
$00002022, $04002022, $00042022, $04042022,
$00000800, $04000800, $00040800, $04040800,
$00000802, $04000802, $00040802, $04040802,
$00002800, $04002800, $00042800, $04042800,
$00002802, $04002802, $00042802, $04042802,
$00000820, $04000820, $00040820, $04040820,
$00000822, $04000822, $00040822, $04040822,
$00002820, $04002820, $00042820, $04042820,
$00002822, $04002822, $00042822, $04042822);
TABQ: array[0..15] of boolean =
(FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE,
FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE);
type
RTTabArray = array[0..31] of LongInt;
procedure TableGen(var t: RTTabArray; UIN: LongInt);
var u: array[0..7] of Byte;
ul: array[0..1] of LongWord absolute u;
v: Byte;
x: Byte;
l,h: LongWord;
a,b,c: LongWord;
begin
{---- create UIN "hash" ----}
v := ((UIN+9) shr 6) and 1;
u[0] := ( ((trunc(sqrt(UIN*3+2)) and 1) or
(((UIN shr 17) and 1) shl 1)) shl 2 ) or v;
u[1] := ( (((trunc(sin(UIN)) shr 14) and 1) or
(((UIN shr 12) and 1) shl 1)) shl 2 ) or v;
u[4] := ( (( (((UIN shr 7) and 1) or
(((UIN shr 12) and 1) shl 1)) shl 1 ) or
((UIN shr 12) and 1)) shl 1 ) or
((UIN shr (UIN and 1)) and 1);
u[6] := ( (( (((trunc(cos(UIN)) shr 8) and 1) or
(((UIN shr 5) and 1) shl 1)) shl 1 ) or
((UIN shr 19) and 1)) shl 1 ) or
((UIN shr 18) and 1);
u[3] := (( ((((UIN shr 9) and 1) shl 1) or
((UIN shr 6) and 1)) shl 1 ) or
(((UIN*5) shr 11) and 1)) shl 1;
u[5] := ( (((trunc(sin(UIN)/cos(UIN){=tan(UIN)}) shr 4) and 1) or
(((UIN shr 11) and 1) shl 1)) shl 2 ) or
((UIN shr 2) and 1);
u[2] := ( (((trunc(sqrt(UIN*3+2)) shr 13) and 1) or
(((UIN shr 10) and 1) shl 1)) shl 2 ) or v;
u[7] := 0;
{---- generate run-time encryption table ----}
l := ul[0];
h := ul[1];
a := (l and $0F0F0F0F) xor ((h shr 4) and $0F0F0F0F);
l := l xor a;
h := h xor (a shl 4);
a := (l and $CCCC0000) xor ((l and $FFFFF333) shl 18);
l := l xor (a xor (a shr 18));
a := (h and $CCCC0000) xor ((h and $FFFFF333) shl 18);
h := h xor (a xor (a shr 18));
a := (l and $55555555) xor ((h shr 1) and $55555555);
l := l xor a;
h := h xor (a shl 1);
a := (h and $00FF00FF) xor ((l shr 8) and $00FF00FF);
l := l xor (a shl 8);
h := h xor a;
a := (l and $55555555) xor ((h shr 1) and $55555555);
l := l xor a;
h := h xor (a shl 1);
a := l and $0FFFFFFF;
b := ( ((l and $F000000F) or ((h shr 12) and $00000FF0)) shr 4 ) or
(h and $0000FF00) or ((h and $FF) shl 16);
for x := 0 to 15 do
begin
if TABQ[x] then
begin
a := ((a and $3F) shl 26) or (a shr 2);
b := ((b and $3F) shl 26) or (b shr 2);
end
else begin
a := ((a and $1F) shl 27) or (a shr 1);
b := ((b and $1F) shl 27) or (b shr 1);
end;
a := a and $0FFFFFFF;
b := b and $0FFFFFFF;
l := TABB[(( ((a and $00C00000) or
((a shr 1) and $07000000)) shr 1 ) or
(a and $00100000)) shr 20] or
TABA[((a and $0001E000) or
((a shr 1) and $00060000)) shr 13] or
TAB9[((a and $C0) or (l shr 1)) shr 6] or
TAB8[a and 63];
h := TABD[((b and $00000180) or
((b shr 1) and $00001E00)) shr 7] or
TABF[((b and $01E00000) or
((b shr 1) and $06000000)) shr 21] or
TABE[(b shr 15) and 63] or
TABC[b and 63];
c := (h and $FFFF0000) or (l shr 16);
t[x*2+0] := (l and $0000FFFF) or (h shl 16);
t[x*2+1] := (c shl 4) or (c shr 28); { = ROL(c,4)}
end;
end;
procedure XORKeyGen(var t: RTTabArray; var KeyLow, KeyHigh: LongInt);
var l, h,
a, b: LongInt;
x: Byte;
begin
l := KeyLow;
h := KeyHigh;
a := (l and $0F0F0F0F) xor ((h shr 4) and $0F0F0F0F);
l := l xor a;
h := h xor (a shl 4);
a := (h and $0000FFFF) xor (l shr 16);
l := l xor (a shl 16);
h := h xor a;
a := (l and $33333333) xor ((h shr 2) and $33333333);
l := l xor a;
h := h xor (a shl 2);
a := (h and $00FF00FF) xor ((l shr 8) and $00FF00FF);
l := l xor (a shl 8);
h := h xor a;
a := (l and $55555555) xor ((h shr 1) and $55555555);
l := l xor a;
h := h xor (a shl 1);
l := (l shl 1) or (l shr 31); {l = ROL(l,1)}
h := (h shl 1) or (h shr 31); {h = ROL(h,1)}
for x := 0 to 7 do
begin
a := t[x*4+0] xor l;
b := t[x*4+1] xor l;
b := (b shr 4) or (b shl 28); {b = ROR(b,4)}
h := (h xor LongInt((TAB2[(a shr 8) and 63] or
TAB3[(b shr 8) and 63] or
TAB4[(a shr 16) and 63] or
TAB5[(b shr 16) and 63] or
TAB6[(a shr 24) and 63] or
TAB7[(b shr 24) and 63] or
TAB1[ b and 63] or
TAB0[ a and 63])));
a := t[x*4+2] xor h;
b := t[x*4+3] xor h;
b := (b shr 4) or (b shl 28); {b = ROR(b,4)}
l := l xor LongInt((TAB2[(a shr 8) and 63] or
TAB3[(b shr 8) and 63] or
TAB4[(a shr 16) and 63] or
TAB5[(b shr 16) and 63] or
TAB6[(a shr 24) and 63] or
TAB7[(b shr 24) and 63] or
TAB1[ b and 63] or
TAB0[ a and 63]));
end;
h := (h shr 1) or (h shl 31); {h = ROR(h,1)}
l := (l shr 1) or (l shl 31); {l = ROR(l,1)}
a := (h and $55555555) xor ((l shr 1) and $55555555);
h := h xor a;
l := l xor (a shl 1);
a := (l and $00FF00FF) xor ((h shr 8) and $00FF00FF);
h := h xor (a shl 8);
l := l xor a;
a := (h and $33333333) xor ((l shr 2) and $33333333);
h := h xor a;
l := l xor (a shl 2);
a := (l and $0000FFFF) xor (h shr 16);
l := l xor a;
h := h xor (a shl 16);
a := (h and $0F0F0F0F) xor ((l shr 4) and $0F0F0F0F);
KeyLow := h xor a;
KeyHigh := l xor (a shl 4);
end;
{Xorkeygen by CoverD}
procedure GetXorKey(FUIN: LongWord; FCryptIV: LongWord; var XorKey: array of Byte);
var
UIN: LongInt;
CryptIV: LongInt;
RTTab: RTTabArray;
l: LongInt;
h: LongInt;
key: array[0..15] of Byte;
keyl: array[0..3] of LongInt absolute key;
x: byte;
begin
UIN := FUIN;
CryptIV := FCryptIV;
TableGen(RTTab, UIN); {create UIN-based run-time encryption table}
l := CryptIV;
h := 0;
XORKeyGen(RTTab, l,h); {generate first 8 bytes of XOR key}
keyl[0] := l;
keyl[1] := h;
XORKeyGen(RTTab, l,h); {generate next 8 bytes (first 3 are used)}
keyl[2] := l;
keyl[3] := h;
for x := 0 to 10 do
XorKey[x] := key[x];
end;
function Decrypt99bPassword(UIN, CryptIV: LongWord; const HexPass: String): String;
var
XorKey,
FBytePassw: array[0..15] of Byte;
i, n: Word;
begin
Result := '';
if (UIN = 0) or (CryptIV = 0) or (Length(HexPass) = 0) then Exit;
GetXorKey(UIN, CryptIV, XorKey);
i := 0;
for n := 1 to Length(HexPass) do
if n mod 2 = 0 then
begin
FBytePassw[i] := HexToInt(Copy(HexPass, n - 1, 2));
Inc(i);
end;
{First 2-bytes -- Length}
for n := 2 to i - 2 do
Result := Result + Chr(FBytePassw[n] xor XorKey[n]);
end;
function DecryptMirandaPassword(const Value: String): String;
var
i: Word;
begin
Result := '';
if Length(Value) < 1 then Exit;
for i := 1 to Length(Value) do
begin
Result := Result + Chr(Ord(Value[i]) - 5);
end;
end;
end.