{$A+,B-,D+,E-,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M 16384,0,0}

(* DBase 2 ASCII-Converter *)
(* Commerceware Copyright (C)1997 Technical Computing Individual *)

USES CRT,
     TC,
     DOS;

CONST
     months : array[1..12]of string[3] =
     ('JAN','FEB','MAR','APR','MAY','JUN',
      'JUL','AUG','SEP','OCT','NOV','DEC');

VAR  F                                              :  FILE of BYTE;
     Dest                                           :  TEXT;
     I,K,NData,J                                    :  INTEGER;
     L,Dp                                           :  array[1..50]of INTEGER;
     test,headsize,headsize2,DataLen                :  BYTE;
     testr                                          :  STRING;
     name,temp                                      :  STRING;
     N                                              :  array[1..50]of STRING[30];
     T                                              :  array[1..50]of STRING[9];
     Memo,Date                                      :  STRING[9];
     availend                                       :  STRING;
     avail1,avail2,avail3,avail4,avail5             :  LONGINT;
     error                                          :  BYTE;

BEGIN
checkbreak:=FALSE;
checksnow :=FALSE;
checkEOF  :=FALSE;

{ loadlogo }
loadpcx('c:\tp\fordos.pcx',error);
Name:=paramstr(0);
Name:=GetFName(Name);
Name:=copy(name,1,(length(name)-4));
for i:=1 to length(name) do name[i]:=upcase(name[i]);

(* Test if the correct number of qualifiers is set up *)
if (paramcount<1) or (paramcount>1) or (paramstr(1)='?') or (paramstr(1)='/?')
or (paramstr(1)='-?') then begin
textcolor(lightblue);
writeLN;
writeLN('DBF-2-ASCII Converter 1.00 Individualware (C)1997 TCSE All rights reserved.');
writeLN('-------------------------------------------------------------------------');
writeLN('Usage:');
writeLN('      ',Name,' [D:][PATH] FILENAME[.EXT]');
textcolor(lightgray);
halt(0);
end;

Name:=paramstr(1);
for i:=1 to length(name) do name[i]:=upcase(name[i]);
(* Open the file and halt if an error occurs *)
if copy(name,(length(name)-3),4)='.DBF' then Assign(f,paramstr(1))
                                                    else Assign(f,paramstr(1)+'.DBF');
reset(f);

case ioresult of
     002: begin writeLN('DBF2ASC (ERR1): File not found - ',name);
                close(f); halt(1); end;

     003: begin writeLN('DBF2ASC (ERR2): Path not found'); close(f); halt(2); end;

     100: begin writeLN('DBF2ASC (ERR4): Read Error - Please check data carrier');
          close(f); halt(4); end;
end;

Read(F,test);
              if (test<>$03) and (test<>$83) then begin
              writeLN('DBF2ASC (ERR3): No DBF-File - ',getfname(name));
              close(f); halt(3); end;
curoff;

(* Version *)
if test=$03 then memo:='dBase III' else memo:='dBase IV';

(* Date of last modification *)
Read(F,test); str(test,date);
Read(F,test); date:=' '+months[test]+' '+date;
Read(F,test); str(test,testr);
date:=testr+date;

(* Data Tracks available  *)
Read(F,test); avail1:=test;
Read(F,test); avail2:=test*256;
Read(F,test); avail3:=test*4096;
Read(F,test); avail4:=test*65535;
avail5:=avail1+avail2+avail3+avail4;
str(avail5,availend);

(* Length of header and data tracks *)
Read(F,headsize);
Read(F,headsize2);
Read(F,datalen);
name:=paramstr(1);
for i:=1 to length(name) do name[i]:=upcase(name[i]);
writeLN;
writeLN;

for i:=1 to length(name) do name[i]:=upcase(name[i]);
if copy(name,(length(name)-3),4)<>'.DBF' then name:=name+'.DBF';
write('Filename: '); if getfname(name)='' then write(name) else write(getfname(name));

gotoXY(35,whereY); writeLN('Number of Data Tracks   : ',availend);
write('Version : ',memo);
gotoXY(35,whereY); writeLN('Length of one Data Track: ',datalen);
writeLN('Date    : ',date);
writeLN;
writeLN('Data Track          Type                Length          Decimal Points');
writeLN('----------          ---------           ------          --------------');
seek(f,32); (* Go to begin of Data track description *)
j:=0;

repeat
inc(j);
for i:=0 to 10 do begin read(F,test);
n[j]:=n[j]+chr(test); end;

read(f,test); case chr(test) of
'C': t[j]:='String';
'N': t[j]:='Numeric';
'L': t[j]:='Logical';
'M': t[j]:='Memotrack';
'D': t[j]:='Date';
end;

for i:=12 to 15 do read(f,test);
read(f,test); l[j]:=test;
read(f,test); dp[j]:=test;
for i:=18 to 31 do read(f,test);
until copy(n[j],1,1)=#13;

dec(j);
ndata:=j;
for i:=1 to j do begin
gotoXY(01,whereY); write(n[i]);
gotoXY(21,whereY); write(t[i]);
gotoXY(41,whereY); write(l[i]);
gotoXY(57,whereY); writeLN(dp[i]);
end;

seek(f,filepos(f)-31);
writeLN;
Assign(dest,copy(name,1,(length(name)-4))+'.ASC'); rewrite(dest);
for k:=1 to Avail5 do begin
    if k>1 then writeLN(dest,'');
    seek(f,filepos(f)+1);
    for i:=1 to NData do begin
        for j:=1 to l[i] do begin read(f,test); temp:=temp+chr(test); end;
        gotoXY(1,whereY); write('Converting data track ',k,' of ',avail5,', quit with <ESC>');
        if keypressed then if readkey=#27 then begin curon; writeLN; writeLN(dest,''); writeLN(dest,'');
                                             writeLN(dest,'TCSE DBF2ASC - Transfer Interrupted!');
                                             close(f); close(dest); halt(0); end;
        if (temp[1]<>'0') and (temp[1]<>'1') and (temp[1]<>'2') and
           (temp[1]<>'3') and (temp[1]<>'4') and (temp[1]<>'5') and
           (temp[1]<>'6') and (temp[1]<>'7') and (temp[1]<>'8') and
           (temp[1]<>'9') then temp:=rtrim(temp);
        if i<ndata
        then write(dest,'"'+temp+'";')
        else write(dest,'"'+temp+'"');
        temp:='';
    end;
end;

(* Clean Up... *)
close(f);
close(dest);
curon;
end.