Solved

Help with convert a program from c++ to delphi and add some fetures.

Posted on 2002-07-06
12
214 Views
Last Modified: 2010-04-04
On
http://nd-net.com/icq2xml.html

there is a c++ program  insidei icqhist-0.91a.zip
that is called icq2xml.cpp

What I like to do is to translate this to delphi and then modify it so It' instead of generating a xml file' add the history to a database (for example an access database)

Can someone help me with that? (it vill be worth a lot of points for me)  
0
Comment
Question by:wqclatre
  • 6
  • 6
12 Comments
 
LVL 6

Expert Comment

by:zebada
ID: 7134339
I have written the code in Delphi but I can't test it because I have no data to test it with.
Can you post some test data? I'll make sure it works and then post the code.

Regards
Paul
0
 
LVL 2

Author Comment

by:wqclatre
ID: 7137035
I leave for another country in one hour. I will try to get som time to send you test-data on thursday (I will leave country again on friday so for the moment I'm a bit bizzy). Do you have an e-mail where I can send a test dat file?
0
 
LVL 6

Expert Comment

by:zebada
ID: 7137043
How about: wqclatre@blacky.co.nz

Cheers
Paul
0
 
LVL 6

Expert Comment

by:zebada
ID: 7153906
No test data so here's the code - untested.

// ICQ database to XML converter
// (database formats 99b to 2001b)
//
// (c)1999-2001 Erwin Aitenbichler <eait@gmx.at>
// This program is released under the terms of the GPL.

program icq2xml;
{$APPTYPE CONSOLE}
uses
  SysUtils;

const
  MAX_FIELDS = 5;
  MAXCONTACTS = 1024;
  DATE_UNIX2DELPHI = 25569;

type
  TContacts = record
    uin: LongWord;
    fields: array[0..MAX_FIELDS-1] of PChar;
  end;

  TIntelLongWord = Record
    case boolean of
      true: (bytes: array[0..3] of char);
      false: (value: LongWord);
  end;

  TIntelWord = Record
    case boolean of
      true: (bytes: array[0..1] of char);
      false: (value: Word);
  end;

var
  fieldNames: array[0..4] of string = ('MyDefinedHandle','NickName','FirstName','LastName','PrimaryEmail');
  fields: array[0..MAX_FIELDS-1] of PChar;
  cnt: integer = 0;
  contacts: array[0..MAXCONTACTS] of TContacts;

// _________________________________________________________________________
function btol(b: PChar): LongWord;
var
  v: TIntelLongWord;
begin
  v.bytes[0] := b[0];
  v.bytes[1] := b[1];
  v.bytes[2] := b[2];
  v.bytes[3] := b[3];
  Result := v.value;
end;

// _________________________________________________________________________
function btos(b: PChar): Word;
var
  v: TIntelWord;
begin
  v.bytes[0] := b[0];
  v.bytes[1] := b[1];
  Result := v.value;
end;

// _________________________________________________________________________
procedure Bwrite(var fd: File; line: string);
begin
  BlockWrite(fd,line,Length(line));
end;

// _________________________________________________________________________
procedure Bwriteln(var fd: File; line: string);
begin
  Bwrite(fd,line);
  BlockWrite(fd,#13#10,2);
end;

// _________________________________________________________________________
procedure contacts_put(uin: WORD);
var
  n,i: integer;
begin
  for n:=0 to cnt-1 do
    if ( uin=contacts[n].uin ) then
      break;
  contacts[n].uin := uin;
  for i:=0 to MAX_FIELDS-1 do
    contacts[n].fields[i] := fields[i];
  if( n=cnt ) then
    Inc(cnt);
end;

// _________________________________________________________________________
function getdate(p: PChar): string;
var
  i: LongWord;
begin
  i := btol(p);
  if ( i<$80000000 ) then
    Result := FormatDateTime('dd.mm.yy',Trunc(i)+DATE_UNIX2DELPHI)
  else
    Result := 'Invalid';
end;

// _________________________________________________________________________
function gettime(p: PChar): string;
var
  i: LongWord;
begin
  i := btol(p);
  if ( i<$80000000 ) then
    Result := FormatDateTime('dd.mm.yy',((i mod 86400)/86400)+DATE_UNIX2DELPHI)
  else
    Result := 'Invalid';
end;

// _________________________________________________________________________
function check_str(buf: PChar; s,l,sz: integer): boolean;
var
  i: integer;
  e: integer;
begin
  Result := false;
  e := s+l-1;
  if ( e>=sz ) then
    exit;
  for i:=s to e-1 do
    if ( buf[i]=chr(0) ) then
      exit;
  result := buf[e]=chr(0);
end;

// _________________________________________________________________________
procedure print_xml(var fd: File ; buf: PChar; l: integer);
var
  i: integer;
begin
  for i:=0 to l-1 do
  begin
    if ( buf[i]='<' ) then
      Bwrite(fd,'&lt;')
    else if ( buf[i]='&' ) then
      Bwrite(fd,'&amp;')
    else
      BlockWrite(fd,buf[i],1);
  end;
end;

// _________________________________________________________________________
function lookup_field(key: PChar): integer;
var
  i: integer;
begin
  for i:=0 to MAX_FIELDS-1 do
    if ( key=fieldNames[i] ) then
    begin
      Result := i;
      exit;
    end;
  Result := -1;
end;

// _________________________________________________________________________
var
  fd: File;
  sz: LongInt;
  buf: array of char;

  i,l,f: integer;
  entryOpen: boolean;
  invalid: boolean;

  dir: string;
  key: PChar;
  vlen: integer;
  uin: integer;

// _________________________________________________________________________
begin
  entryOpen := false;
  invalid := false;

  if ( ParamCount<2 ) then
  begin
    Writeln('ICQ database to XML converter 0.91 - (c)2001 Erwin Aitenbichler');
    Writeln('(For database formats 99b and newer)');
    Writeln('This program is released under the terms of the GPL');
    Writeln('syntax: icq2xml <datfile>');
    Writeln('        generates "contacts.xml" and "history.xml"');
    exit;
  end;

  try
    AssignFile(fd,ParamStr(1));
    FileMode := 1; {Set file access to readonly }
    Reset(fd,1);
    sz := FileSize(fd);
    SetLength(buf,sz);
    BlockRead(fd,buf,sz);
    closeFile(fd);
  except
    on Exception do
    begin
      Writeln('Can''t open input file: ',ParamStr(1));
      exit;
    end;
  end;

  try
    AssignFile(fd,'history.xml');
    FileMode := 2; {Set file access to read/write }
    Rewrite(fd,1);
  except
    on Exception do
    begin
      Writeln('Can''t create/open output file: history.xml for writing');
      exit;
    end;
  end;

  Bwriteln(fd,'<?xml version="1.0" encoding="iso-8859-1"?>');
  Bwriteln(fd,'<?xml-stylesheet type="text/xsl" href="history.xsl"?>');
  Bwriteln(fd,'<history>');

  for i:=0 to MAX_FIELDS-1 do
    fields[i] := nil;

  i := 0;
  while ( i<sz ) do
  begin
    l := btos(@buf[i]);

    if ( (i>=9) and
         (l>1) and
         (
           (
             (Ord(buf[i-9]) or Ord(buf[i-8]) or Ord(buf[i-7]) or Ord(buf[i-5]))=0) and
             (Ord(buf[i-6])=1)
           ) and
           check_str(@buf[0],i+2,l,sz) and
           (Ord(buf[i+l+15])>$32)
         ) then              // newer than 01.08.1996
      begin
        if ( Ord(buf[i+l+6])=0 ) then
          dir := 'incomming'
        else
          dir := 'outgoing';

        Bwriteln(fd,Format('<entry uin="%d" secs="%d" date="%s" time="%s" dir="%s">',
                          [btol(@buf[i-4]),btol(@buf[i+l+12]),getdate(@buf[i+l+12]),gettime(@buf[i+l+12]),dir]));
        print_xml(fd,@buf[i+2],l-1);
        Bwriteln(fd,'</entry>');
        invalid := true;
      end
    else if ( (l>1) and check_str(@buf[0],i+2,l,sz) ) then
    begin
      if ( invalid ) then
      begin
        for f:=0 to MAX_FIELDS-1 do
          fields[f] := nil;
        invalid := false;
      end;
      key := @buf[i+2];
      if ( buf[i+l+2]='k' ) then
      begin
        vlen := btos(@buf[i+l+3]);
        if ( check_str(@buf[0],i+l+5,vlen,sz) ) then
        begin
          if ( vlen>1 ) then
          begin
            f := lookup_field(key);
            if ( f>=0 ) then
              fields[f] := @buf[i+l+5];
          end;
          Inc(i,2+l+1+2+vlen-1);
        end;
      end
      else if ( buf[i+l+2]='i' ) then
      begin
        if ( key='UIN' ) then
        begin
          uin := btol(@buf[i+l+3]);
          if ( (fields[1]<>nil) or (fields[2]<>nil) ) then
            contacts_put(uin);
        end;
        Inc(i,2+l+1+4-1);
      end
      else if ( (buf[i+l+2]='d') or (buf[i+l+2]='e') ) then
      begin
        // skip 1 byte
        Inc(i,2+l+1);
      end
      else if ( (buf[i+l+2]='f') or (buf[i+l+2]='g') ) then
      begin
        // skip 2 bytes
        Inc(i,2+l+1+1);
      end
      else
        invalid := true
    end
    else
      invalid := true;
  end;
  if ( entryOpen ) then
    Bwriteln(fd,'</entry>');
  Bwriteln(fd,'</history>');
  CloseFile(fd);

  try
    AssignFile(fd,'contacts.xml');
    FileMode := 2; {Set file access to read/write }
    Rewrite(fd,1);
  except
    on Exception do
    begin
      Writeln('Can''t create/open output file: contacts.xml for writing');
      exit;
    end;
  end;

  Bwriteln(fd,'<?xml version="1.0" encoding="iso-8859-1"?>');
  Bwriteln(fd,'<?xml-stylesheet type="text/xsl" href="contacts.xsl"?>');
  Bwriteln(fd,'<contacts>');
  for i:=0 to cnt-1 do
  begin
    Bwriteln(fd,Format('<entry uin="%d">',[contacts[i].uin]));
    for f:=0 to MAX_FIELDs-1 do
    begin
      if ( contacts[i].fields[f]<>nil ) then
      begin
        Bwrite(fd,Format('<%s>',[fieldNames[f]]));
        print_xml(fd,contacts[i].fields[f],Length(contacts[i].fields[f]));
        Bwrite(fd,Format('</%s>',[fieldNames[f]]));
      end;
    end;
    Bwriteln(fd,'</entry>');
  end;
  Bwriteln(fd,'</contacts>');
  CloseFile(fd);
end.




0
 
LVL 2

Author Comment

by:wqclatre
ID: 7181222
Sorry for my late comment. Had to much to do before I went on vacation. Just got back so I will try this tomorrow (or send you test-data)
0
 
LVL 2

Author Comment

by:wqclatre
ID: 7183447
It seems like it doesn't work for me... I will send you a test file now.
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 2

Author Comment

by:wqclatre
ID: 7183461
done
0
 
LVL 6

Expert Comment

by:zebada
ID: 7183978
Ok, here's the fixed version (there were a couple of bugs) that appears to work OK with the test data.

It could be written a whole lot better in Delphi using different Delphi datatypes and constructs - I just did a line for line translation of the C code to the Delphi code.

// ICQ database to XML converter
// (database formats 99b to 2001b)
//
// (c)1999-2001 Erwin Aitenbichler <eait@gmx.at>
// This program is released under the terms of the GPL.
//
// Program translated from C to Delphi by
// Paul Blackmore <delphi@blacky.co.nz>

program icq2xml;
{$APPTYPE CONSOLE}
uses
  SysUtils;

const
  MAX_FIELDS = 5;
  MAXCONTACTS = 1024;
  DATE_UNIX2DELPHI = 25569;

type
  TContacts = record
    uin: LongWord;
    fields: array[0..MAX_FIELDS-1] of PChar;
  end;

  TIntelLongWord = Record
    case boolean of
      true: (bytes: array[0..3] of char);
      false: (value: LongWord);
  end;

  TIntelWord = Record
    case boolean of
      true: (bytes: array[0..1] of char);
      false: (value: Word);
  end;

var
  fieldNames: array[0..4] of string = ('MyDefinedHandle','NickName','FirstName','LastName','PrimaryEmail');
  fields: array[0..MAX_FIELDS-1] of PChar;
  cnt: integer = 0;
  contacts: array[0..MAXCONTACTS] of TContacts;

// _________________________________________________________________________
function btol(b: PChar): LongWord;
var
  v: TIntelLongWord;
begin
  v.bytes[0] := b[0];
  v.bytes[1] := b[1];
  v.bytes[2] := b[2];
  v.bytes[3] := b[3];
  Result := v.value;
end;

// _________________________________________________________________________
function btos(b: PChar): Word;
var
  v: TIntelWord;
begin
  v.bytes[0] := b[0];
  v.bytes[1] := b[1];
  Result := v.value;
end;

// _________________________________________________________________________
procedure Bwrite(var fd: File; line: string);
var
  written: integer;
begin
  BlockWrite(fd,line[1],Length(line),written);
end;

// _________________________________________________________________________
procedure Bwriteln(var fd: File; line: string);
begin
  Bwrite(fd,line);
  BlockWrite(fd,#13#10,2);
end;

// _________________________________________________________________________
procedure contacts_put(uin: WORD);
var
  n,i: integer;
begin
  n := 0;
  while ( n<cnt ) do
  begin
    if ( uin=contacts[n].uin ) then
      break;
    Inc(n);
  end;
  contacts[n].uin := uin;
  for i:=0 to MAX_FIELDS-1 do
    contacts[n].fields[i] := fields[i];
  if( n=cnt ) then
    Inc(cnt);
end;

// _________________________________________________________________________
function getdate(p: PChar): string;
var
  i: LongWord;
begin
  i := btol(p);
  if ( i<$80000000 ) then
    Result := FormatDateTime('dd.mm.yy',Trunc(i)+DATE_UNIX2DELPHI)
  else
    Result := 'Invalid';
end;

// _________________________________________________________________________
function gettime(p: PChar): string;
var
  i: LongWord;
begin
  i := btol(p);
  if ( i<$80000000 ) then
    Result := FormatDateTime('dd.mm.yy',((i mod 86400)/86400)+DATE_UNIX2DELPHI)
  else
    Result := 'Invalid';
end;

// _________________________________________________________________________
function check_str(buf: PChar; s,l,sz: integer): boolean;
var
  i: integer;
  e: integer;
begin
  Result := false;
  e := s+l-1;
  if ( e>=sz ) then
    exit;
  for i:=s to e-1 do
    if ( buf[i]=chr(0) ) then
      exit;
  result := buf[e]=chr(0);
end;

// _________________________________________________________________________
procedure print_xml(var fd: File ; buf: PChar; l: integer);
var
  i: integer;
begin
  for i:=0 to l-1 do
  begin
    if ( buf[i]='<' ) then
      Bwrite(fd,'&lt;')
    else if ( buf[i]='&' ) then
      Bwrite(fd,'&amp;')
    else
      BlockWrite(fd,buf[i],1);
  end;
end;

// _________________________________________________________________________
function lookup_field(key: PChar): integer;
var
  i: integer;
begin
  for i:=0 to MAX_FIELDS-1 do
    if ( key=fieldNames[i] ) then
    begin
      Result := i;
      exit;
    end;
  Result := -1;
end;

// _________________________________________________________________________
var
  fd: File;
  sz: LongInt;
  buf: array of char;

  i,l,f,r: integer;
  entryOpen: boolean;
  invalid: boolean;

  dir: string;
  key: PChar;
  vlen: integer;
  uin: integer;

// _________________________________________________________________________
begin
  entryOpen := false;
  invalid := false;

  if ( ParamCount<1 ) then
  begin
    Writeln('ICQ database to XML converter 0.91 - (c)2001 Erwin Aitenbichler');
    Writeln('(For database formats 99b and newer)');
    Writeln('This program is released under the terms of the GPL');
    Writeln('');
    Writeln('Program translated from C to Delphi by');
    Writeln('Paul Blackmore <delphi@blacky.co.nz>');
    Writeln('');
    Writeln('syntax: icq2xml <datfile>');
    Writeln('        generates "contacts.xml" and "history.xml"');
    exit;
  end;

  try
    AssignFile(fd,ParamStr(1));
    FileMode := 2; {Set file access to read/write }
    Reset(fd,1);
    sz := FileSize(fd);
    SetLength(buf,sz);
    try
      BlockRead(fd,buf[0],sz,r);
      if ( r<>sz ) then
        Raise Exception.Create('Unexpected end of file');
    except
      on e:Exception do
      begin
        closeFile(fd);
        Writeln('Can''t read from input file: ',ParamStr(1),'. ',e.Message);
        exit;
      end;
    end;
    closeFile(fd);
  except
    on e:Exception do
    begin
      Writeln('Can''t open input file: ',ParamStr(1),'. ',e.Message);
      exit;
    end;
  end;

  try
    AssignFile(fd,'history.xml');
    FileMode := 2; {Set file access to read/write }
    Rewrite(fd,1);
  except
    on Exception do
    begin
      Writeln('Can''t create/open output file: history.xml for writing');
      exit;
    end;
  end;

  Bwriteln(fd,'<?xml version="1.0" encoding="iso-8859-1"?>');
  Bwriteln(fd,'<?xml-stylesheet type="text/xsl" href="history.xsl"?>');
  Bwriteln(fd,'<history>');

  for i:=0 to MAX_FIELDS-1 do
    fields[i] := nil;

  i := 0;
  while ( i<sz ) do
  begin
    l := btos(@buf[i]);

    if ( (i>=9) and
         (l>1) and
         (
           (
             (Ord(buf[i-9]) or Ord(buf[i-8]) or Ord(buf[i-7]) or Ord(buf[i-5]))=0) and
             (Ord(buf[i-6])=1)
           ) and
           check_str(@buf[0],i+2,l,sz) and
           (Ord(buf[i+l+15])>$32)
         ) then              // newer than 01.08.1996
      begin
        if ( Ord(buf[i+l+6])=0 ) then
          dir := 'incomming'
        else
          dir := 'outgoing';

        Bwriteln(fd,Format('<entry uin="%d" secs="%d" date="%s" time="%s" dir="%s">',
                          [btol(@buf[i-4]),btol(@buf[i+l+12]),getdate(@buf[i+l+12]),gettime(@buf[i+l+12]),dir]));
        print_xml(fd,@buf[i+2],l-1);
        Bwriteln(fd,'</entry>');
        invalid := true;
      end
    else if ( (l>1) and check_str(@buf[0],i+2,l,sz) ) then
    begin
      if ( invalid ) then
      begin
        for f:=0 to MAX_FIELDS-1 do
          fields[f] := nil;
        invalid := false;
      end;
      key := @buf[i+2];
      if ( buf[i+l+2]='k' ) then
      begin
        vlen := btos(@buf[i+l+3]);
        if ( check_str(@buf[0],i+l+5,vlen,sz) ) then
        begin
          if ( vlen>1 ) then
          begin
            f := lookup_field(key);
            if ( f>=0 ) then
              fields[f] := @buf[i+l+5];
          end;
          Inc(i,2+l+1+2+vlen-1);
        end;
      end
      else if ( buf[i+l+2]='i' ) then
      begin
        if ( key='UIN' ) then
        begin
          uin := btol(@buf[i+l+3]);
          if ( (fields[1]<>nil) or (fields[2]<>nil) ) then
            contacts_put(uin);
        end;
        Inc(i,2+l+1+4-1);
      end
      else if ( (buf[i+l+2]='d') or (buf[i+l+2]='e') ) then
      begin
        // skip 1 byte
        Inc(i,2+l+1);
      end
      else if ( (buf[i+l+2]='f') or (buf[i+l+2]='g') ) then
      begin
        // skip 2 bytes
        Inc(i,2+l+1+1);
      end
      else
        invalid := true
    end
    else
      invalid := true;
    Inc(i);
  end;
  if ( entryOpen ) then
    Bwriteln(fd,'</entry>');
  Bwriteln(fd,'</history>');
  CloseFile(fd);

  try
    AssignFile(fd,'contacts.xml');
    FileMode := 2; {Set file access to read/write }
    Rewrite(fd,1);
  except
    on Exception do
    begin
      Writeln('Can''t create/open output file: contacts.xml for writing');
      exit;
    end;
  end;

  Bwriteln(fd,'<?xml version="1.0" encoding="iso-8859-1"?>');
  Bwriteln(fd,'<?xml-stylesheet type="text/xsl" href="contacts.xsl"?>');
  Bwriteln(fd,'<contacts>');
  for i:=0 to cnt-1 do
  begin
    Bwriteln(fd,Format('<entry uin="%d">',[contacts[i].uin]));
    for f:=0 to MAX_FIELDs-1 do
    begin
      if ( contacts[i].fields[f]<>nil ) then
      begin
        Bwrite(fd,Format('<%s>',[fieldNames[f]]));
        print_xml(fd,contacts[i].fields[f],Length(contacts[i].fields[f]));
        Bwrite(fd,Format('</%s>',[fieldNames[f]]));
      end;
    end;
    Bwriteln(fd,'</entry>');
  end;
  Bwriteln(fd,'</contacts>');
  CloseFile(fd);
end.


0
 
LVL 6

Expert Comment

by:zebada
ID: 7183984
I've just compared outputs - still some bugs with data format - I'll fix and repost.
0
 
LVL 6

Accepted Solution

by:
zebada earned 500 total points
ID: 7183996
Bugs fixed :)

// ICQ database to XML converter
// (database formats 99b to 2001b)
//
// (c)1999-2001 Erwin Aitenbichler <eait@gmx.at>
// This program is released under the terms of the GPL.
//
// Program translated from C to Delphi by
// Paul Blackmore <delphi@blacky.co.nz>

program icq2xml;
{$APPTYPE CONSOLE}
uses
  SysUtils;

const
  MAX_FIELDS = 5;
  MAXCONTACTS = 1024;
  DATE_UNIX2DELPHI = 25570;
  SEC_PER_DAY = 86400;

type
  TContacts = record
    uin: LongWord;
    fields: array[0..MAX_FIELDS-1] of PChar;
  end;

  TIntelLongWord = Record
    case boolean of
      true: (bytes: array[0..3] of char);
      false: (value: LongWord);
  end;

  TIntelWord = Record
    case boolean of
      true: (bytes: array[0..1] of char);
      false: (value: Word);
  end;

var
  fieldNames: array[0..4] of string = ('MyDefinedHandle','NickName','FirstName','LastName','PrimaryEmail');
  fields: array[0..MAX_FIELDS-1] of PChar;
  cnt: integer = 0;
  contacts: array[0..MAXCONTACTS] of TContacts;

// _________________________________________________________________________
function btol(b: PChar): LongWord;
var
  v: TIntelLongWord;
begin
  v.bytes[0] := b[0];
  v.bytes[1] := b[1];
  v.bytes[2] := b[2];
  v.bytes[3] := b[3];
  Result := v.value;
end;

// _________________________________________________________________________
function btos(b: PChar): Word;
var
  v: TIntelWord;
begin
  v.bytes[0] := b[0];
  v.bytes[1] := b[1];
  Result := v.value;
end;

// _________________________________________________________________________
procedure Bwrite(var fd: File; line: string);
var
  written: integer;
begin
  BlockWrite(fd,line[1],Length(line),written);
end;

// _________________________________________________________________________
procedure Bwriteln(var fd: File; line: string);
begin
  Bwrite(fd,line);
  BlockWrite(fd,#13#10,2);
end;

// _________________________________________________________________________
procedure contacts_put(uin: LongWord);
var
  n,i: integer;
begin
  n := 0;
  while ( n<cnt ) do
  begin
    if ( uin=contacts[n].uin ) then
      break;
    Inc(n);
  end;
  contacts[n].uin := uin;
  for i:=0 to MAX_FIELDS-1 do
    contacts[n].fields[i] := fields[i];
  if( n=cnt ) then
    Inc(cnt);
end;

// _________________________________________________________________________
function getdate(p: PChar): string;
var
  i: LongWord;
begin
  i := btol(p);
  if ( i<$80000000 ) then
    Result := FormatDateTime('dd.mm.yyyy',Trunc(i/SEC_PER_DAY)+DATE_UNIX2DELPHI)
  else
    Result := 'Invalid';
end;

// _________________________________________________________________________
function gettime(p: PChar): string;
var
  i: LongWord;
begin
  i := btol(p);
  if ( i<$80000000 ) then
    Result := FormatDateTime('hh:nn',((i mod SEC_PER_DAY)/SEC_PER_DAY))
  else
    Result := 'Invalid';
end;

// _________________________________________________________________________
function check_str(buf: PChar; s,l,sz: integer): boolean;
var
  i: integer;
  e: integer;
begin
  Result := false;
  e := s+l-1;
  if ( e>=sz ) then
    exit;
  for i:=s to e-1 do
    if ( buf[i]=chr(0) ) then
      exit;
  result := buf[e]=chr(0);
end;

// _________________________________________________________________________
procedure print_xml(var fd: File ; buf: PChar; l: integer);
var
  i: integer;
begin
  for i:=0 to l-1 do
  begin
    if ( buf[i]='<' ) then
      Bwrite(fd,'&lt;')
    else if ( buf[i]='&' ) then
      Bwrite(fd,'&amp;')
    else
      BlockWrite(fd,buf[i],1);
  end;
end;

// _________________________________________________________________________
function lookup_field(key: PChar): integer;
var
  i: integer;
begin
  for i:=0 to MAX_FIELDS-1 do
    if ( key=fieldNames[i] ) then
    begin
      Result := i;
      exit;
    end;
  Result := -1;
end;

// _________________________________________________________________________
var
  fd: File;
  sz: LongInt;
  buf: array of char;

  i,l,f,r: integer;
  entryOpen: boolean;
  invalid: boolean;

  dir: string;
  key: PChar;
  vlen: integer;
  uin: LongWord;

// _________________________________________________________________________
begin
  entryOpen := false;
  invalid := false;

  if ( ParamCount<1 ) then
  begin
    Writeln('ICQ database to XML converter 0.91 - (c)2001 Erwin Aitenbichler');
    Writeln('(For database formats 99b and newer)');
    Writeln('This program is released under the terms of the GPL');
    Writeln('');
    Writeln('Program translated from C to Delphi by');
    Writeln('Paul Blackmore <delphi@blacky.co.nz>');
    Writeln('');
    Writeln('syntax: icq2xml <datfile>');
    Writeln('        generates "contacts.xml" and "history.xml"');
    exit;
  end;

  try
    AssignFile(fd,ParamStr(1));
    FileMode := 2; {Set file access to read/write }
    Reset(fd,1);
    sz := FileSize(fd);
    SetLength(buf,sz);
    try
      BlockRead(fd,buf[0],sz,r);
      if ( r<>sz ) then
        Raise Exception.Create('Unexpected end of file');
    except
      on e:Exception do
      begin
        closeFile(fd);
        Writeln('Can''t read from input file: ',ParamStr(1),'. ',e.Message);
        exit;
      end;
    end;
    closeFile(fd);
  except
    on e:Exception do
    begin
      Writeln('Can''t open input file: ',ParamStr(1),'. ',e.Message);
      exit;
    end;
  end;

  try
    AssignFile(fd,'history.xml');
    FileMode := 2; {Set file access to read/write }
    Rewrite(fd,1);
  except
    on Exception do
    begin
      Writeln('Can''t create/open output file: history.xml for writing');
      exit;
    end;
  end;

  Bwriteln(fd,'<?xml version="1.0" encoding="iso-8859-1"?>');
  Bwriteln(fd,'<?xml-stylesheet type="text/xsl" href="history.xsl"?>');
  Bwriteln(fd,'<history>');

  for i:=0 to MAX_FIELDS-1 do
    fields[i] := nil;

  i := 0;
  while ( i<sz ) do
  begin
    l := btos(@buf[i]);

    if ( (i>=9) and
         (l>1) and
         (
           (
             (Ord(buf[i-9]) or Ord(buf[i-8]) or Ord(buf[i-7]) or Ord(buf[i-5]))=0) and
             (Ord(buf[i-6])=1)
           ) and
           check_str(@buf[0],i+2,l,sz) and
           (Ord(buf[i+l+15])>$32)
         ) then              // newer than 01.08.1996
      begin
        if ( Ord(buf[i+l+6])=0 ) then
          dir := 'incomming'
        else
          dir := 'outgoing';

        Bwriteln(fd,Format('<entry uin="%d" secs="%d" date="%s" time="%s" dir="%s">',
                          [btol(@buf[i-4]),btol(@buf[i+l+12]),getdate(@buf[i+l+12]),gettime(@buf[i+l+12]),dir]));
        print_xml(fd,@buf[i+2],l-1);
        Bwriteln(fd,'</entry>');
        invalid := true;
      end
    else if ( (l>1) and check_str(@buf[0],i+2,l,sz) ) then
    begin
      if ( invalid ) then
      begin
        for f:=0 to MAX_FIELDS-1 do
          fields[f] := nil;
        invalid := false;
      end;
      key := @buf[i+2];
      if ( buf[i+l+2]='k' ) then
      begin
        vlen := btos(@buf[i+l+3]);
        if ( check_str(@buf[0],i+l+5,vlen,sz) ) then
        begin
          if ( vlen>1 ) then
          begin
            f := lookup_field(key);
            if ( f>=0 ) then
              fields[f] := @buf[i+l+5];
          end;
          Inc(i,2+l+1+2+vlen-1);
        end;
      end
      else if ( buf[i+l+2]='i' ) then
      begin
        if ( key='UIN' ) then
        begin
          uin := btol(@buf[i+l+3]);
          if ( (fields[1]<>nil) or (fields[2]<>nil) ) then
            contacts_put(uin);
        end;
        Inc(i,2+l+1+4-1);
      end
      else if ( (buf[i+l+2]='d') or (buf[i+l+2]='e') ) then
      begin
        // skip 1 byte
        Inc(i,2+l+1);
      end
      else if ( (buf[i+l+2]='f') or (buf[i+l+2]='g') ) then
      begin
        // skip 2 bytes
        Inc(i,2+l+1+1);
      end
      else
        invalid := true
    end
    else
      invalid := true;
    Inc(i);
  end;
  if ( entryOpen ) then
    Bwriteln(fd,'</entry>');
  Bwriteln(fd,'</history>');
  CloseFile(fd);

  try
    AssignFile(fd,'contacts.xml');
    FileMode := 2; {Set file access to read/write }
    Rewrite(fd,1);
  except
    on Exception do
    begin
      Writeln('Can''t create/open output file: contacts.xml for writing');
      exit;
    end;
  end;

  Bwriteln(fd,'<?xml version="1.0" encoding="iso-8859-1"?>');
  Bwriteln(fd,'<?xml-stylesheet type="text/xsl" href="contacts.xsl"?>');
  Bwriteln(fd,'<contacts>');
  for i:=0 to cnt-1 do
  begin
    Bwriteln(fd,Format('<entry uin="%d">',[contacts[i].uin]));
    for f:=0 to MAX_FIELDs-1 do
    begin
      if ( contacts[i].fields[f]<>nil ) then
      begin
        Bwrite(fd,Format('<%s>',[fieldNames[f]]));
        print_xml(fd,contacts[i].fields[f],Length(contacts[i].fields[f]));
        Bwrite(fd,Format('</%s>',[fieldNames[f]]));
      end;
    end;
    Bwriteln(fd,'</entry>');
  end;
  Bwriteln(fd,'</contacts>');
  CloseFile(fd);
end.


0
 
LVL 2

Author Comment

by:wqclatre
ID: 7191138
Thanks... works wounderfoul
0
 
LVL 2

Author Comment

by:wqclatre
ID: 7191275
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
Concerto provides fully managed cloud services and the expertise to provide an easy and reliable route to the cloud. Our best-in-class solutions help you address the toughest IT challenges, find new efficiencies and deliver the best application expe…
The Email Laundry PDF encryption service allows companies to send confidential encrypted  emails to anybody. The PDF document can also contain attachments that are embedded in the encrypted PDF. The password is randomly generated by The Email Laundr…

919 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now