icqdb.pas

本程序是转载的

begin
  Result := ReadStr(FDHandle, ReadInt(FDHandle, 2));
end;

{Global variables in ParseDatEntry procedure}
var
  FNickName: String;
  FFirstName: String;
  FLastName: String;
  FEmail: String;
  FLastUpdate: String;
  FAge, FGender: Byte;
  FUIN: LongWord;
  FMsg, FMsg2, FMsg3: String;
  FFlag: LongWord;
  FSeparator: Word;
  FSubType: Word;
  FTStamp: LongWord;

  FPassword: String;
  FCryptIV: LongWord;

procedure ReadProperty;
var
  Len: Word;
  AName: String;
  Num, PropNum, i, n: LongWord;
  CType: Byte;
  Cmd: Byte;
begin
  Len := ReadInt(FDHandle, 2);
  AName := ReadStr(FDHandle, Len);
  Cmd := ReadInt(FDHandle, 1);
  case Cmd of
    $64: {Char}
      Read64h;
    $65: {Byte}
      if AName = 'Age' then
        FAge := Read65h
      else if AName = 'Gender' then
        FGender := Read65h
      else
        Read65h;
    $66: {Word}
      Read66h;
    $67: {Integer}
      Read67h;
    $68: {DWord}
      if AName = '99BCryptIV' then
        FCryptIV := Read68h
      else
        Read68h;
    $69: {LongInt}
      if AName = 'UIN' then
        FUIN := Read69h
      else
        Read69h;
    $6b: {LNTS}
      if AName = 'NickName' then
        FNickName := Read6bh
      else if AName = 'FirstName' then
        FFirstName := Read6bh
      else if AName = 'LastName' then
        FLastName := Read6bh
      else if AName = 'PrimaryEmail' then
        FEmail := Read6bh
      else if AName = 'Password' then begin
        if FPassword = '' then                  //For some unknown reasons, password is stored many times with null value
          FPassword := Read6bh
        else
          Read6bh
      end else
        Read6bh;
    $6d: {Sublist}
    begin
      Num := ReadInt(FDHandle, 4);
      CType := ReadInt(FDHandle, 1);
      if Num > 0 then
        for i := 0 to Num - 1 do
          case CType of
            $6b:
              Skip(FDHandle, ReadInt(FDHandle, 2));
            $6e:
            begin
              Skip(FDHandle, 2);                //Separator value
              PropNum := ReadInt(FDHandle, 4);  //Number of properties
              if PropNum > 0 then
                for n := 0 to PropNum - 1 do
                  ReadProperty;                 //Parse each property (call recursively)
            end;
          end;
    end;
    $6f: {DWORD (length) + BYTE array}
      Skip(FDHandle, ReadInt(FDHandle, 4));
  end;
end;

procedure ReadPropertyBlock;
var
  Num, i: LongWord;
begin
  Skip(FDHandle, 2);                            //Separator value
  Num := ReadInt(FDHandle, 4);                  //Number of user properties
  if Num > 0 then
    for i := 0 to Num - 1 do
      ReadProperty;
end;

procedure ReadWavEntry;
begin
  Skip(FDHandle, 2);                            //Separator value
  Skip(FDHandle, 4);                            //User event for which Wav will be played
  Skip(FDHandle, 4);                            //0: play default WAV, 1: play the user-specified WAV
  ReadLNTS(FDHandle);                           //Full path and file name of WAV
end;

procedure ReadWavBlock;
var
  Num, i: LongWord;
begin
  Num := ReadInt(FDHandle, 4);            //Number of user event WAV entries
  if Num > 0 then
    for i := 0 to Num - 1 do
      ReadWavEntry;
  Skip(FDHandle, 2);                      //Separator value
end;

var
  Dat: TDatRec;
  Num: LongWord;
  i: LongWord;
  FURL, FDesc: String;
begin
  if FDHandle = INVALID_HANDLE_VALUE then Exit;
  if ReadBuf(FDHandle, SizeOf(Dat), Dat) <> SizeOf(Dat) then Exit;
  case Dat.Command of
    $e0, $a0: {Short Message & URL Format (ICQ 99a-2002a)}
    begin
      Skip(FDHandle, 2);                        //Separator
      Skip(FDHandle, 4);                        //Filing flags
      FSubType := ReadInt(FDHandle, 2);         //Entry sub type: 1: Message; 4: URL; 19: Contacts
      if (FSubType <> 1) and (FSubType <> 4) then
        Exit;
      FUIN := ReadInt(FDHandle, 4);             //UIN of sender/receiver
      FMsg := ReadStr(FDHandle, ReadInt(FDHandle, 2));
      Skip(FDHandle, 4);                        //Status of receiving user
      FFlag := ReadInt(FDHandle, 4);            //Sent or received: 0: Received, 1: Sent
      Skip(FDHandle, 2);                        //Separator value
      FTStamp := ReadInt(FDHandle, 4);          //Timestamp, time of last update
      FLastUpdate := TimeStamp2Str(FTStamp);
      if FSubType = 1 then begin
        if Assigned(OnMessageFound) then
          FOnMessage(Self, FUIN, FFlag = 0, FMsg, FLastUpdate, FTStamp);
      end else
      if FSubType = 4 then begin
        FDesc := Copy(FMsg, 0, Pos(#$fe, FMsg) - 1);
        FURL := Copy(FMsg, Pos(#$fe, FMsg) + 1, Length(FMsg) - Pos(#$fe, FMsg));
        if Assigned(OnUrlFound) then
          FOnUrl(Self, FUIN, FFlag = 0, FDesc, FURL, FLastUpdate, FTStamp);
      end;
    end;
    $e4: {My details}
    begin
      if Dat.Number <> 1005 then Exit;
      FNickName := ''; FFirstName := ''; FLastName := '';  FEmail := '';
      FPassword := ''; FAge := 0; FGender := 0; FUIN := 0;
      FSeparator := ReadInt(FDHandle, 2);       //Separator
      if ReadStr(FDHandle, 4) <> 'RESU' then    //Label   = 55534552h ('USER')
        Exit;
      if ReadInt(FDHandle, 4) <> 6 then Exit;   //User entry status: 6 = "My Details"
      Skip(FDHandle, 4);                        //0 (Unknown, most likely an unused group entry)
      Skip(FDHandle, 2);                        //Separator value
      {Some modifications in ICQ2000x}
      if (FDbVersion = DB_2000a) or (FDbVersion = DB_2000b) then
        ReadWavBlock;
      {Some modifications in ICQ2002a}
      if (FSeparator >= 533) and (FDbVersion = DB_2001a) then begin
        Skip(FDHandle, 4);                      //0 (Unknown, if this can be longer than a long it will most likely crash the importer
        Skip(FDHandle, 2);                      //Separator value
      end;
      Num := ReadInt(FDHandle, 4);              //Number of property blocks
      if Num > 0 then
        for i := 0 to Num - 1 do
          ReadPropertyBlock;
      Skip(FDHandle, 2);                        //Separator value
      FTStamp := ReadInt(FDHandle, 4);          //Timestamp, time of last update
      FLastUpdate := TimeStamp2Str(FTStamp);
      FPassword := Decrypt99bPassword(FUIN, FCryptIV, FPassword);
      if Assigned(OnSelfInfoFound) then
        FOnSelfInfo(Self, FUIN, FNickName, FFirstName, FLastName, FEmail, FPassword, FAge, FGender, FLastUpdate, FTStamp);
    end;
    $e5: {Contact entry}
    begin
      FNickName := ''; FFirstName := ''; FLastName := '';  FEmail := '';
      FAge := 0; FGender := 0; FUIN := 0;
      FSeparator := ReadInt(FDHandle, 2);       //Separator
      if ReadStr(FDHandle, 4) <> 'RESU' then    //Label   = 55534552h ('USER')
        Exit;
      ReadInt(FDHandle, 4);                     //User entry status
      ReadInt(FDHandle, 4);                     //GroupID of contact group containing user
      Skip(FDHandle, 2);                        //Separator value
      {Some modifications in ICQ2000x}
      if (FDbVersion = DB_2000a) or (FDbVersion = DB_2000b) then
        ReadWavBlock;
      {Some modifications in ICQ2002a}
      if (FSeparator >= 533) and (FDbVersion = DB_2001a) then begin
        Skip(FDHandle, 4);                      //Unknown, 0
        Skip(FDHandle, 2);                      //Separator value
      end;
      Num := ReadInt(FDHandle, 4);              //Number of property blocks
      if Num > 0 then
        for i := 0 to Num - 1 do
          ReadPropertyBlock;
      Skip(FDHandle, 2);                        //Separator value
      FTStamp := ReadInt(FDHandle, 4);          //Timestamp, time of last update
      FLastUpdate := TimeStamp2Str(FTStamp);
      if Assigned(OnContactFound) then
        FOnContact(Self, FUIN, FNickName, FFirstName, FLastName, FEmail, FAge, FGender, FLastUpdate, FTStamp);
    end;
    $50: {Long Message Format (ICQ 99a-2002a)}
    begin
      Skip(FDHandle, 2);                        //Separator
      Skip(FDHandle, 4);                        //Filing flags
      Skip(FDHandle, 2);                        //Entry sub type
      FUIN := ReadInt(FDHandle, 4);             //UIN of sender/receiver
      FMsg := ReadLNTS(FDHandle);               //ANSI text
      Skip(FDHandle, 4);                        //Status of receiving user
      FFlag := ReadInt(FDHandle, 4);            //Sent or received: 0: Received, 1: Sent
      Skip(FDHandle, 2);                        //Separator value
      FTStamp := ReadInt(FDHandle, 4);          //Timestamp, time of last update
      FLastUpdate := TimeStamp2Str(FTStamp);
      Skip(FDHandle, 19);                       //Zeroes
      FMsg2 := ReadLNTS(FDHandle);              //Rich Text
      FMsg3 := ReadLNTS(FDHandle);              //UTF-8 Text
      if Assigned(OnAdvMessageFound) then
        FOnAdvMessage(Self, FUIN, FFlag = 0, FMsg, FMsg2, FMsg3, FLastUpdate, FTStamp);
    end;
  end;
end;

procedure TICQDb.ParseMirandaDatFile;
{Global variables in ParseMirandaDatFile procedure}
var
  FNickName: String;
  FFirstName: String;
  FLastName: String;
  FEmail: String;
  FLastUpdate: String;
  FAge, FGender: Byte;
  FUIN: LongWord;
  FMsg: String;
  FPassword: String;


function GetModuleName(Ofs: LongWord): String;
type
  TDBModuleName = record
    Signature: LongWord;
    ofsNext: LongWord;
    cbName: Byte;
  end;
var
  FMod: TDbModuleName;
  FCurrOff: LongWord;
begin
  Result := '';
  FCurrOff := GetPos(FDHandle);
  if not Seek(FDHandle, Ofs) then Exit;
  if ReadBuf(FDHandle, SizeOf(FMod), FMod) <> SizeOf(FMod) then Exit;
  Result := ReadStr(FDHandle, FMod.cbName);
  Seek(FDHandle, FCurrOff);
end;

function ReadContactSettings(Ofs: LongWord): Boolean;
function ReadByte: Byte;
begin
  Result := ReadInt(FDHandle, 1);
end;

function ReadWord: Word;
begin
  Result := ReadInt(FDHandle, 2);
end;

function ReadDWord: LongWord;
begin
  Result := ReadInt(FDHandle, 4);
end;

function ReadASCIIZ: String;
begin
  Result := ReadStr(FDHandle, ReadWord);
end;

procedure ReadParams(Len: LongWord);
var
  FName: String;
  __pos: LongWord;
begin
  __pos := GetPos(FDHandle);
  while True do begin
    FName := ReadStr(FDHandle, ReadByte);
    if FName = '' then Break;                   //We acheived end of property list
    case ReadByte of
      DBVT_DELETED: Exit;                       //This setting just got deleted, no other values are valid
      DBVT_BYTE:
        if FName = 'Gender' then begin
          FGender := ReadByte;
          if Chr(FGender) = 'M' then
            FGender := GEN_MALE
          else if Chr(FGender) = 'F' then
            FGender := GEN_FEMALE
          else
            FGender := 0;
        end else
          ReadByte;
      DBVT_WORD:
        if FName = 'age' then
          FAge := ReadWord
        else
          ReadWord;
      DBVT_DWORD:
        if FName = 'UIN' then
          FUIN := ReadDWord
        else
          ReadDWord;
      DBVT_ASCIIZ:
        if FName = 'Nick' then
          FNickName :=  ReadASCIIZ
        else if FName = 'FirstName' then
          FFirstName := ReadASCIIZ
        else if FName = 'LastName' then
          FLastName := ReadASCIIZ
        else if FName = 'e-mail' then
          FEmail := ReadASCIIZ
        else if FName = 'Password' then
          FPassword := DecryptMirandaPassword(ReadASCIIZ)
        else
          ReadASCIIZ;
      DBVT_BLOB:
        Skip(FDHandle, ReadDWord);
      DBVTF_VARIABLELENGTH:
        Exit;
    else
      Exit;
    end;
    if GetPos(FDHandle) >= __pos + Len then Break;
  end;
end;
var
  FDbset: TDBContactSettings;
  FModName: String;
begin
  FNickName := ''; FFirstName := ''; FLastName := '';
  FEmail := ''; FLastUpdate := ''; FAge := 0;
  FGender := 0; FUIN := 0; FMsg := ''; Result := False;
  if not Seek(FDHandle, Ofs) then Exit;
  while True do begin
    if ReadBuf(FDHandle, SizeOf(FDbSet), FDbSet) <> SizeOf(FDbSet) then Break;
    FModName := GetModuleName(FDbSet.ofsModuleName);
    //if FModName = '' then                       //Do not parse any module settings
      ReadParams(FDbSet.cbBlob);                //Parse contact params
    if FDbSet.ofsNext = 0 then Break;
    if not Seek(FDHandle, FDbSet.ofsNext) then Break;
  end;
  Result := True;
end;

procedure ReadEvents(Ofs: LongWord);
var
  FDbEvent: TDbEvent;
  FDesc: String;
  FURL: String;
begin
  if not Seek(FDHandle, Ofs) then Exit;
  while True do begin
    if ReadBuf(FDHandle, SizeOf(TDbEvent), FDbEvent) <> SizeOf(TDbEvent) then Break;
    if FDbEvent.Signature <> DBEVENT_SIGNATURE then Break;
    //if GetModuleName(FDbEvent.ofsModuleName) = '' then  //Parse only miranda's events
      if (FDbEvent.eventType = EVENTTYPE_MESSAGE) or
         (FDbEvent.eventType = EVENTTYPE_URL) then
      begin
        FMsg := ReadStr(FDHandle, FDbEvent.cbBlob);
        if FDbEvent.eventType = EVENTTYPE_MESSAGE then begin
          if Assigned(OnMessageFound) then
            FOnMessage(Self, FUIN, FDbEvent.flags and DBEF_SENT <> DBEF_SENT, FMsg, TimeStamp2Str(FDbEvent.Timestamp), FDbEvent.Timestamp);
        end else begin
          FDesc := Copy(FMsg, 0, Pos(#$fe, FMsg) - 1);
          FURL := Copy(FMsg, Pos(#$fe, FMsg) + 1, Length(FMsg) - Pos(#$fe, FMsg));
          if Assigned(OnUrlFound) then
            FOnUrl(Self, FUIN, FDbEvent.flags and DBEF_SENT <> DBEF_SENT, FDesc, FURL, TimeStamp2Str(FDbEvent.Timestamp), FDbEvent.Timestamp);
        end;
      end;
    if FDbEvent.ofsNext = 0 then Break;
    if not Seek(FDHandle, FDbEvent.ofsNext) then Break;
  end;
end;

var
  FContact: TMirandaContact;
  i: Word;
begin
  if Assigned(OnParsingStarted) then
    FOnParsingStarted(Self);
  if Assigned(OnProgress) then
    FOnProgress(Self, 0);
  i := 1;
  if not Seek(FDHandle, FMirandaHdr.ofsFirstContact) then Exit;
  if FMirandaHdr.contactCount > 0 then
    while True do begin
      if ReadBuf(FDHandle, SizeOf(FContact), FContact) <> SizeOf(FContact) then Break;
      if ReadContactSettings(FContact.ofsFirstSettings) then
        if Assigned(OnContactFound) then                  //It's called here because of same property reader for the self info
          FOnContact(Self, FUIN, FNickName, FFirstName, FLastName, FEmail, FAge, FGender, '', 0);
      ReadEvents(FContact.ofsFirstEvent);
      if FContact.ofsNext = 0 then Break;
      if not Seek(FDhandle, FContact.ofsNext) then Break;
      if Assigned(OnProgress) then
        FOnProgress(Self, Round((i / FMirandaHdr.contactCount) * 100));
      Inc(i);
    end;
  if (FMirandaHdr.ofsUser = 0) or (not Seek(FDHandle, FMirandaHdr.ofsUser)) then Exit;
  if ReadBuf(FDHandle, SizeOf(FContact), FContact) <> SizeOf(FContact) then Exit;
  FPassword := '';
  if ReadContactSettings(FContact.ofsFirstSettings) then
    if Assigned(OnSelfInfoFound) then
      FOnSelfInfo(Self, FUIN, FNickName, FFirstName, FLastName, FEmail, FPassword, FAge, FGender, '', 0);
  CloseDat;     
  if Assigned(OnProgress) then
    FOnProgress(Self, 100);
  if Assigned(OnParsingFinished) then
    FOnParsingFinished(Self);
end;

procedure Register;
begin
  RegisterComponents('Standard', [TICQDb]);
end;

end.