Solved

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

Posted on 2002-07-06
12
217 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
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!

 
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

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

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…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

733 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