[кекеке]

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, ScktComp;

type
  TForm1 = class(TForm)
    ClientSocket1: TClientSocket;
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  Pers = record
    ID: string;
    rait: integer;
    nick: string;
    clan: string;
    x: integer;
  end;

var
  Form1: TForm1;
  users: array [1..70] of pers;
  ParseStack: string;
  reccode, startedplanet: string;
  MyId,Mypass: string;
  Hash:string;
    var_6b8e: integer=0;
    var_6bae: integer=0;
    var_6b9e: integer=0;
    var_6b96: integer=0;
    ctc: integer=1;
    ctct: integer;

implementation

{$R *.dfm}

function NextStr(var s: string):string;
var
i: integer;
begin
i:=pos(' ',s);
if i<>0 then begin
  result:=copy(s,1,i-1);
  delete(s,1,i);
end else begin
  result:=s;
  s:='';
end;
end;


function UpperCaseRU(s: string): string;
var
  i: integer;
begin
  result := s;
  for i := 1 to length(result) do
    if (result[i] in ['a'..'z', 'а'..'я']) then
      result[i] := chr(ord(result[i]) - 32)
    else if result[i]='ё' then result[i]:='Ё';

end;

  function sub_1cfc(i,j:integer): integer;
  var
  k: integer;
  begin
  k:=1;
  while (j > 0) do begin
    if((j mod 2) = 1)
        then k:=k*i;
    j:= j shr 1;
    i := i*i;
  end;
  result:=k;
  end;

  function ConvertCTKey(s: string):integer;
  var
  l,r: integer;
  begin
    r:=0;
    for l:=1 to length(s) do begin
      r:=(r shl 8) + ord(s[l]);
    end;
    result:=r;
  end;

  procedure SendText(s:string);
    procedure ParseText(s:string);
    procedure ProgRun;

  procedure TForm1.SendText(s:string);
  var
  i,j: integer;
  begin
    var_6b9e:=var_6b9e+length(s);
    var_6bae:=var_6bae+1;
    s:=ansitoutf8(s);
    oursock.socket.SendText(s+#13#10);
    inc(ctc);
    if ctc=(ctct+1) then begin
      ctc:=1;
      if(var_6b8e = 0) then
        var_6b8e:= var_6b96;
      i:=sub_1cfc(var_6b8e,var_6bae);
      j:= var_6b96 shl var_6b9e;
      var_6b8e:= i xor j;
      oursock.socket.SendText('ct '+inttostr(var_6b8e)+#13#10);
    end;
end;

function GetEmptyUser:integer;
var
  i: integer;
begin
result:=-1;
  for i:=1 to 70 do
      if users[i].ID='0' then begin
        result:=i;
        break;
      end;
end;

procedure EraseUser(N: integer);
begin
  users[n].ID:='0';
  users[n].rait:=0;
  users[n].nick:='-';
  users[n].clan:='-';
  users[n].x:=0;
end;

procedure EraseAllUsers;
var
  i:byte;
begin
  for i:=1 to 70 do
    EraseUser(i);
end;

procedure LoadUsers(s:string);// парсинг юзеров
var
  i:integer;
  tpos:integer;
  ind: integer;
  sub:string;
begin
  s:=copy(s,pos(':',s)+1,length(s));
  s:=utf8toansi(s);
  i:=GetEmptyUser;
while true do begin
    if length(s)<10 then break;
    users[i].clan:=Nextstr(s);
    users[i].nick:=NextStr(s);
if users[i].nick[1]='+' then begin
    delete(users[i].nick,1,1);
end;
if users[i].nick[1]='@' then begin
    delete(users[i].nick,1,1);
end;
    users[i].id:=Nextstr(s);
if Nextstr(s) = '-1' then begin
NextStr(s); NextStr(s);
NextStr(s); NextStr(s);
NextStr(s);
end else begin
  NextStr(s);
end;
    users[i].x:=Strtoint(Nextstr(s));
    inc(i);
end;
end;

procedure TForm1.ParseText(s:string);
var
  sub:string;
  i:integer;
  cmd: string;
begin
if s='' then exit;
cmd:=NextStr(s);
if cmd='HAAAPSI' then begin
  sub:=NextStr(s);
  HASH:=GHash.CreateHash(sub);
  var_6b96:=ConvertCTKey(sub);
  ctct:=strtoint(NextStr(s));
  sendtext(':ru IDENT 111 -1 4030 1 2 :GALA');
  sendtext('RECOVER '+reccode);
end else
if cmd='REGISTER' then begin
  MyID:=NextStr(s);
  MyPass:=NextStr(s);
  sendtext('USER'+' '+MyId+' '+MyPass+' 0 '+HASH);
end else
if cmd='999' then begin
  Sendtext('FWLISTVER 0');
  sendtext('ADDONS');
  sendtext('MYADDONS');
  Sendtext('JOIN '+StartedPlanet);
end else
if cmd='PING' then begin
  sendtext('PONG');
end else
if cmd='LBS' then begin
  sendtext('LBS 2 platform=MPP cellid=null mcc=null mnc=null lac=null');
end else
if cmd='353' then begin
LoadUsers(s);
form1.ProgRun;
end;
end;

procedure TForm1.ProgRun;
begin
  Timer1.Interval:=StrToInt(Edit3.text);
  Timer1.Enabled:=true;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
var
  id: String;
  i: integer;
begin
Timer1.Enabled:=false;
id:='hz';
if RadioButton1.Checked then
  for i:=1 to 70 do
    if UpperCaseRU(Edit4.Text)=UpperCaseRu(Users[i].nick) then begin
        id:=users[i].ID;
        break;
    end;
if RadioButton2.Checked then
  for i:=1 to 70 do
    if UpperCaseRU(Edit5.Text)=UpperCaseRu(Users[i].clan) then begin
        id:=users[i].ID;
        break;
    end;
if id<>'hz' then SendText('ACTION 3 '+id);
SendText('QUIT :ds');
OurSock.Close;
end;

end;


procedure TForm1.Button1Click(Sender: TObject);
begin
EraseAllUsers;
  reccode:=Edit1.Text;
  StartedPlanet:=Edit2.text;
  OurSock.Active:=true;
end;

procedure TForm1.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
begin
var
  recv: string;
  l: integer;
  send: string;
begin
recv:=Socket.ReceiveText;
ParseStack:=ParseStack+recv;
l:=pos(#13#10,ParseStack);;
while l>0 do begin
  recv:=copy(ParseStack,1,l+1);
  parsetext(recv);
  Delete(ParseStack,1,l+1);
  l:=pos(#13#10,ParseStack);
end;
end;

end.