Solved

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

Posted on 2002-07-06
12
213 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
Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

 
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

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Suggested Solutions

Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
In this seventh video of the Xpdf series, we discuss and demonstrate the PDFfonts utility, which lists all the fonts used in a PDF file. It does this via a command line interface, making it suitable for use in programs, scripts, batch files — any pl…
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

759 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

18 Experts available now in Live!

Get 1:1 Help Now