Solved

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

Posted on 2002-07-06
12
221 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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
 
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

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
NetCrunch network monitor is a highly extensive platform for network monitoring and alert generation. In this video you'll see a live demo of NetCrunch with most notable features explained in a walk-through manner. You'll also get to know the philos…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.

717 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