icqdb.pas

本程序是转载的

unit ICQDb {v 1.19};
{(C) Alex Demchenko([e-mail])}
{$R-}

interface
uses
  Windows, Messages, ICQWorks, SysUtils, Classes, ICQLang;

const
  {Database versions}
  DB_99A = 10;   {99a}
  DB_99B = 14;   {99b}
  DB_2000a = 17; {2000a}
  DB_2000b = 18; {2000b}
  DB_2001a = 19; {2001a, 2001b, 2002a, 2003a}
  DB_MIRANDA121 = $00000700; {Miranda 1.2.1, 1.2.0}

const
  {Miranda-icq signatures}
  DBHEADER_SIGNATURE: array[0..15] of Char = ('M', 'i', 'r', 'a', 'n', 'd', 'a', ' ',   'I', 'C', 'Q', ' ', 'D', 'B', #$00, #$1a);
  DBCONTACT_SIGNATURE: LongWord         = $43DECADE;
  DBMODULENAME_SIGNATURE: LongWord      = $4DDECADE;
  DBCONTACTSETTINGS_SIGNATURE: LongWord = $53DECADE;
  DBEVENT_SIGNATURE: LongWord           = $45DECADE;

  {Miranda-icq data types}
  DBVT_DELETED = 0;    //this setting just got deleted, no other values are valid
  DBVT_BYTE    = 1;    //bVal and cVal are valid
  DBVT_WORD    = 2;    //wVal and sVal are valid
  DBVT_DWORD   = 4;    //dVal and lVal are valid
  DBVT_ASCIIZ  = 255;  //pszVal is valid
  DBVT_BLOB    = 254;  //cpbVal and pbVal are valid
  DBVTF_VARIABLELENGTH = $80;

  {Miranda-icq database flags}
  DBEF_FIRST   = 1;    //this is the first event in the chain;
  DBEF_SENT    = 2;    //this event was sent by the user. If not set this
  DBEF_READ    = 4;    //event has been read by the user. It does not need

  {Miranda-icq event types}
  EVENTTYPE_MESSAGE     = 0;           //Message
  EVENTTYPE_URL         = 1;           //URL
  EVENTTYPE_ADDED       = 1000;        //v0.1.1.0+: these used to be module-
  EVENTTYPE_AUTHREQUEST = 1001;        //specific codes, hence the module-
  EVENTTYPE_FILE        = 1002;        //specific limit has been raised to 2000


type
  TOnErrorEvent = procedure(Sender: TObject; Reason: Word; ReasonStr: String) of object;
  TOnProgress = procedure(Sender: TObject; Progress: Byte) of object;
  TOnContact = procedure(Sender: TObject; UIN: LongWord; NickName, FirstName, LastName,
    Email: String; Age, Gender: Byte; LastUpdate: String; LastUpdateStamp: LongWord) of object;
  TOnSelfInfo = procedure(Sender: TObject; UIN: LongWord; NickName, FirstName, LastName,
    Email, Password: String; Age, Gender: Byte; LastUpdate: String; LastUpdateStamp: LongWord) of object;
  TOnMessage = procedure(Sender: TObject; UIN: LongWord; Incoming: Boolean; Msg, RecvTime: String; RecvTimeStamp: LongWord) of object;
  TOnUrl = procedure(Sender: TObject; UIN: LongWord; Incoming: Boolean; Description, URL, RecvTime: String; RecvTimeStamp: LongWord) of object;
  TOnAdvMessage = procedure(Sender: TObject; UIN: LongWord; Incoming: Boolean; PlainText, RichText, UTF8Text, RecvTime: String; RecvTimeStamp: LongWord) of object;

  {Index record}
  TIdxRec = record
    Code,                                       //If entry is valid the it's set to -2
    Number,                                     //DAT entry number
    Next,                                       //Next IdxRec offset
    Prev,                                       //Previous IdxRec offset
    DatPos: LongInt;                            //Offset in .dat file
  end;

  {Dat header record}
  TDatRec = record
    Length,
    FillType,
    Number: LongInt;
    Command: Byte;
    Signature: array[0..14] of Byte;
  end;

  {Miranda .dat header}
  TMirandaHdr = record
    Signature: array[0..15] of Byte;
    Version: LongWord;
    ofsFileEnd: LongWord;
    slackSpace: LongWord;
    contactCount: LongWord;
    ofsFirstContact: LongWord;
    ofsUser: LongWord;
    ofsFirstModuleName: LongWord;
  end;

  {Miranda's contact entry}
  TMirandaContact = record
    Signature: DWord;
    ofsNext: DWord;
    ofsFirstSettings: DWord;
    eventCount: DWord;
    ofsFirstEvent, ofsLastEvent: DWord;
    ofsFirstUnreadEvent: DWord;
    timestampFirstUnread: DWord;
  end;

  {Miranda's contact settings}
  TDBContactSettings = record
    Signature: LongWord;
    ofsNext: LongWord;
    ofsModuleName: LongWord;
    cbBlob: LongWord
  end;

  {Miranda's event}
  TDBEvent = packed record
    Signature: LongWord;
    ofsPrev: LongWord;
    ofsNext: LongWord;
    ofsModuleName: LongWord;
    Timestamp: LongWord;
    Flags: LongWord;
    eventType: Word;
    cbBlob: LongWord;
  end;

  {Component}
  TICQDb = class(TComponent)
  private
    FIdxFile, FDatFile: String;
    FHandle: THandle;                           //Main .idx file handle
    FDHandle: THandle;                          //Main .dat file handle
    FIdxRoot: LongWord;                         //Root .idx entry
    FIdxEntries: LongWord;                      //Count of idx entries
    FDbVersion: LongWord;                       //Database version extracted from .idx file
    FMirandaHdr: TMirandaHdr;
    {-=-=-=-=-}
    FOnError: TOnErrorEvent;
    FOnParsingStarted: TNotifyEvent;
    FOnParsingFinished: TNotifyEvent;
    FOnProgress: TOnProgress;
    FOnContact: TOnContact;
    FOnSelfInfo: TOnSelfInfo;
    FOnMessage: TOnMessage;
    FOnURL: TOnUrl;
    FOnAdvMessage: TOnAdvMessage;
    FDbType: TDbType;
    FErrLang: TICQLangType;
    function ReadInt(Handle: THandle; Len: ShortInt): LongWord;
    function ReadBuf(Handle: THandle; Len: LongWord; var Buf): LongWord;
    function ReadStr(Handle: THandle; Len: LongWord): String;
    function ReadLNTS(Handle: THandle): String;
    procedure Skip(Handle: THandle; Len: LongWord);
    function Seek(Handle: THandle; Pos: LongWord): Boolean;
    function GetPos(Handle: THandle): LongWord;
    function OpenIdx(const FileName: String): Boolean;
    procedure CloseIdx;
    function OpenDat(const FileName: String): Boolean;
    procedure CloseDat;
    function IsMiranda: Boolean;
    function IsICQ: Boolean;
    function ReadHeader: Boolean;
    function ReadIdxChunk(var IdxRec: TIdxRec): Boolean;
    procedure ParseIndexes;
    procedure ParseDatEntry;
    procedure ParseMirandaDatFile;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure StartParsing;
    property DbType: TDbType read FDbType;
  published
    property DatFile: String read FDatFile write FDatFile;
    property OnError: TOnErrorEvent read FOnError write FOnError;
    property DbVersion: LongWord read FDbVersion;
    property OnParsingStarted: TNotifyEvent read FOnParsingStarted write FOnParsingStarted;
    property OnParsingFinished: TNotifyEvent read FOnParsingFinished write FOnParsingFinished;
    property OnProgress: TOnProgress read FOnProgress write FOnProgress;
    property OnContactFound: TOnContact read FOnContact write FOnContact;
    property OnSelfInfoFound: TOnSelfInfo read FOnSelfInfo write FOnSelfInfo;
    property OnMessageFound: TOnMessage read FOnMessage write FOnMessage;
    property OnURLFound: TOnUrl read FOnUrl write FOnUrl;
    property OnAdvMessageFound: TOnAdvMessage read FOnAdvMessage write FOnAdvMessage;
    property ErrorLanguage: TICQLangType read FErrLang write FErrLang default LANG_EN;
  end;

procedure Register;

implementation
function TimeStamp2Str(Timestamp: LongWord): String;
var
  DelphiTime: Double;
begin
  DelphiTime := EncodeDate(1970, 1, 1) + (TimeStamp / 86400);
  Result := DateTimeToStr(DelphiTime);
end;

constructor TICQDb.Create;
begin
  inherited;
  FHandle := INVALID_HANDLE_VALUE;
  FDHandle := INVALID_HANDLE_VALUE;
end;

destructor TICQDb.Destroy;
begin
  CloseIdx; CloseDat;
  inherited;
end;

function TICQDb.IsMiranda: Boolean;
begin
  FDbType := DB_MIRANDA;
  Result := OpenDat(FDatFile);
  if (Result) and (not ReadHeader) then begin
    Result := False;
    CloseDat;
  end;
end;

function TICQDb.IsICQ: Boolean;
begin
  FDbType := DB_ICQ;
  Result := OpenIdx(FIdxFile) and OpenDat(FDatFile);
  if (Result) and (not ReadHeader) then begin
    Result := False; 
    CloseDat; CloseIdx;
    Exit;
  end;
end;

procedure TICQDb.StartParsing;
begin
  FIdxFile := Copy(FDatFile, 0, Pos('.', FDatFile) - 1) + '.idx';
  if (not IsICQ) and (not IsMiranda) then begin
    if Assigned(OnError) then
      FOnError(Self, IMSG_EDB_EFILEOPEN, ICQLanguages[FErrLang].Translate(IMSG_EDB_EFILEOPEN));
    Exit;
  end;
  if (FDbVersion <> DB_2001a) and (FDbVersion <> DB_2000a) and
     (FDbVersion <> DB_2000b) and (FDbVersion <> DB_MIRANDA121)
  then begin
    CloseDat; CloseIdx;
    if Assigned(OnError) then
      FOnError(Self, IMSG_EDB_EDBVERNOTSUPPORTED, ICQLanguages[FErrLang].Translate(IMSG_EDB_EDBVERNOTSUPPORTED));
     Exit;
  end;
  if FDbType = DB_ICQ then ParseIndexes else ParseMirandaDatFile;
end;

function TICQDb.ReadInt(Handle: THandle; Len: ShortInt): LongWord;
var
  buf: array[0..3] of Byte;
  read: LongWord;
begin
  Result := 0;
  if (Len < 0) or (Len > 4) then
    Exit;
  FillChar(buf, SizeOf(buf), 0);
  ReadFile(Handle, buf, Len, read, nil);
  if read < 1 then Exit;
  Result := PLongWord(@buf)^;
end;

function TICQDb.ReadBuf(Handle: THandle; Len: LongWord; var Buf): LongWord;
begin
  if Len = 0 then Exit;
  ReadFile(Handle, Buf, Len, Result, nil);
end;

function TICQDb.ReadStr(Handle: THandle; Len: LongWord): String;
var
  buf: Pointer;
  read: LongWord;
begin
  Result := '';
  GetMem(buf, Len);
  if Len = 0 then Exit;
  ReadFile(Handle, buf^, Len, read, nil);
  if read < 1 then begin
    FreeMem(buf);
    Exit;
  end;
  Result := Copy(PChar(buf), 0, Len);
  FreeMem(buf);
end;

function TICQDb.ReadLNTS(Handle: THandle): String;
begin
  Result := ReadStr(Handle, ReadInt(Handle, 2));
end;

procedure TICQDb.Skip(Handle: THandle; Len: LongWord);
begin
  SetFilePointer(Handle, SetFilePointer(Handle, 0, nil, 1) + Len, nil, 0)
end;

function TICQDb.Seek(Handle: THandle; Pos: LongWord): Boolean;
begin
  Result := SetFilePointer(Handle, Pos, nil, 0) <> LongWord(-1);
end;

function TICQDb.GetPos(Handle: THandle): LongWord;
begin
  Result := SetFilePointer(Handle, 0, nil, 1);
end;

function TICQDb.OpenIdx(const FileName: String): Boolean;
begin
  Result := False;
  CloseIdx;
  FHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if FHandle = INVALID_HANDLE_VALUE then Exit;
  if SetFilePointer(FHandle, 0, nil, 0) = LongWord(-1) then begin
    CloseIdx;
    Exit;
  end;
  Result := True;
end;

procedure TICQDb.CloseIdx;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FHandle);
  FHandle := INVALID_HANDLE_VALUE;
end;

function TICQDb.OpenDat(const FileName: String): Boolean;
begin
  Result := False;
  CloseDat;
  FDHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if FDHandle = INVALID_HANDLE_VALUE then Exit;
  if SetFilePointer(FDHandle, 0, nil, 0) = LongWord(-1) then begin
    CloseDat;
    Exit;
  end;
  Result := True;
end;

procedure TICQDb.CloseDat;
begin
  if FDHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FDHandle);
  FDHandle := INVALID_HANDLE_VALUE;
end;

function TICQDb.ReadHeader: Boolean;
var
  Size: LongWord;
begin
  Result := False;
  if DbType = DB_ICQ then begin
    Size := FileSize(FIdxFile);
    if Size <> INVALID_FILE_SIZE then
      FIdxEntries := (Size - 20) div (SizeOf(TIdxRec) shl 4)
    else
      Exit;
    if FHandle = INVALID_HANDLE_VALUE then Exit;
    if (ReadInt(FHandle, 4) <> 4) or (ReadInt(FHandle, 4) <> 20) or
       (ReadInt(FHandle, 4) <> 8) then
      Exit;
    FIdxRoot := ReadInt(FHandle, 4);
    FDbVersion := ReadInt(FHandle, 4);
  end else begin
    Size := FileSize(FDatFile);
    if Size = INVALID_FILE_SIZE then Exit;
    if ReadBuf(FDHandle, SizeOf(TMirandaHdr), FMirandaHdr) <> SizeOf(TMirandaHdr) then Exit;
    FDbVersion := FMirandaHdr.Version;
    if not CompareMem(@FMirandaHdr.Signature, @DBHEADER_SIGNATURE, 16) then
      Exit;
  end;
  Result := True;
end;

function TICQDb.ReadIdxChunk(var IdxRec: TIdxRec): Boolean;
begin
  Result := False;
  if FHandle = INVALID_HANDLE_VALUE then Exit;
  if IdxRec.Next = -1 then Exit;
  if SetFilePointer(FHandle, IdxRec.Next, nil, 0) = LongWord(-1) then
    Exit;
  if FHandle = INVALID_HANDLE_VALUE then Exit;
  if ReadBuf(FHandle, SizeOf(TIdxRec), IdxRec) <> SizeOf(TIdxRec) then
    Exit;
  Result := True;
end;

procedure TICQDb.ParseIndexes;
var
  idx: TIdxRec;
  i: LongWord;
begin
  if Assigned(OnParsingStarted) then
    FOnParsingStarted(Self);
  idx.Next := FIdxRoot;
  i := 0;
  while ReadIdxChunk(idx) do begin
    if idx.Code = -2 then
    begin
      if idx.DatPos <> -1 then                    {if it's not a root entry}
        if not Seek(FDhandle, idx.DatPos) then
          Break
        else
          ParseDatEntry;
    end;
    Inc(i);
    if (Assigned(OnProgress)) and (FIdxEntries > 0) then
      FOnProgress(Self, Round((i / FIdxEntries) * 100));
  end;
  CloseIdx; CloseDat;
  if Assigned(OnProgress) then
    FOnProgress(Self, 100);
  if Assigned(OnParsingFinished) then
    FOnParsingFinished(Self);
end;

procedure TICQDb.ParseDatEntry;
function Read64h: Char;
begin
  Result := Chr(ReadInt(FDHandle, 1));
end;

function Read65h: Byte;
begin
  Result := ReadInt(FDHandle, 1);
end;

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

function Read67h: Integer;
begin
  Result := ReadInt(FDHandle, 2);
end;

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

function Read69h: LongInt;
begin
  Result := ReadInt(FDHandle, 4);
end;

function Read6bh: String;