Power-Programmierung/CD1.mdf/pascal/library/dos/database/dbffix/dbffix.pas

Pascal/Delphi Source File | 1992-01-21 | 31.3 KB | 867 lines

{Program to allow a dbf file to be edited to fix problems in file structure}
uses dos;

{Information related to dBase file formats.  Written in pascal, rather than C}
{since it may eventually be useful in SCHED                                  }

{Information below courtesy Mark Sadler}
(* dBASE III DATABASE FILE HEADER:
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0      |  1 byte           | dBASE III version number        |
|         |                   |  (03H without a .DBT file)      |
|         |                   |  (83H with a .DBT file)         |
+---------+-------------------+---------------------------------+
|  1-3    |  3 bytes          | date of last update             |
|         |                   |  (YY MM DD) in binary format    |
+---------+-------------------+---------------------------------+
|  4-7    |  32 bit number    | number of records in data file  |
+---------+-------------------+---------------------------------+
|  8-9    |  16 bit number    | length of header structure      |
+---------+-------------------+---------------------------------+
|  10-11  |  16 bit number    | length of the record            |
+---------+-------------------+---------------------------------+
|  12-31  |  20 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
|  32-n   |  32 bytes each    | field descriptor array          |
|         |                   |  (see below)                    | --+
+---------+-------------------+---------------------------------+   |
|  n+1    |  1 byte           | 0DH as the field terminator     |   |
+---------+-------------------+---------------------------------+   |
|                                                                   |
|                                                                   |
A FIELD DESCRIPTOR:      <------------------------------------------+
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0-10   |  11 bytes         | field name in ASCII zero-filled |
+---------+-------------------+---------------------------------+
|  11     |  1 byte           | field type in ASCII             |
|         |                   |  (C N L D or M)                 |
+---------+-------------------+---------------------------------+
|  12-15  |  32 bit number    | field data address              |
|         |                   |  (address is set in memory)     |
+---------+-------------------+---------------------------------+
|  16     |  1 byte           | field length in binary          |
+---------+-------------------+---------------------------------+
|  17     |  1 byte           | field decimal count in binary   |
+---------+-------------------+--------------------------------
|  18-31  |  14 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
The data records are layed out as follows:
1. Data records are preceeded by one byte that is a
space (20H) if the record is not deleted and an
asterisk (2AH) if it is deleted.
2. Data fields are packed into records with no field
separators or record terminators.
3. Data types are stored in ASCII format as follows:
DATA TYPE      DATA RECORD STORAGE
---------      --------------------------------------------
Character      (ASCII characters)
Numeric        - . 0 1 2 3 4 5 6 7 8 9
Logical        ? Y y N n T t F f  (? when not initialized)
Memo           (10 digits representing a .DBT block number)
Date           (8 digits in YYYYMMDD format, such as
19840704 for July 4, 1984)

This information came directly from the Ashton-Tate Forum. It can also be
found in the Advanced Programmer's Guide available from Ashton-Tate.

One slight difference occurs between files created by dBASE III and those
created by dBASE III Plus.  In the earlier files, there is an ASCII NUL
character between the $0D end of header indicator and the start of the
data. This NUL is no longer present in Plus, making a Plus header one byte
smaller than an identically structured III file.  The functions included
here will work with either version of dBASE III and writes files which may
be used by either.
*)

type

dbfHdr =                             {32 byte file header}
 record
  dBIIIvers : byte;                  {03h without .dbt file}
  lrevYear  : byte;                  {last revision year modulo 100}
  lrevMo    : byte;
  lrevDay   : byte;
  numRecs      : longint;               {number of records in data file}
  hdrLen    : word;                  {size of header in bytes}
  recLen    : word;                  {length of data record}
  v100res   : array[1..20] of byte;  {reserved bytes in version 1.00 set nul}
 end;


dbfFldDes =                          {32 byte descriptor one for each field}
 record
  field_name : array[1..11] of char; {name of field in ascii}
  field_typ  : char;                 {one of C,N,L,D, or M}
  f_dta_adr  : longint;              {used in memory - set zero in file}
  f_len      : byte;                 {length of field}
  dec_pl     : byte;                 {number of decimals in binary}
  v100res    : array[1..14] of byte; {reserved bytes in version 1.00 set nul}
 end;

dbIIIhdrTail =                       {goes at end of header & counts in size}
 record                              {for dbIII this is two bytes}
  ODhbyte : byte;
  OOhbyte : byte;
 end;

dbIIIplushdrTail =                   {for dbIII+ only one byte}
 record
  ODhbyte : byte;
 end;


{The entire header, then is a dbfHdr followed by an array of dbfFldDes of}
{unknown size (max 128 fields)                                           }
{For reading an unknown .dbf file, use an array of 128 and overlay the   }
{actual header with the formal data type.  For setting up a new one,     }
{dimension the array in a type declaration.  Rembember the tail.         }
{for convenience, put the file variable in the header                    }

genericHdr =
 record
  fil : file;
  h   : dbfHdr;
  f   : array[1..128] of dbfFldDes;
 end;

ghPtr = ^genericHdr;

{fielding a record is a bit more of a job.  Would be a lot easier in C and }
{a whole lot easier in C++ where we could overload operators.  However     }
{we can fudge it in pascal by declaring an array [1..128] of appropriate   }
{structures to handle the records                                          }

field_ary = array[1..254] of char;
f_ap      = ^field_ary;

field_des =
 record
  f_name : string[11];    {copy name of field here for convenience}
  f_len  : byte;          {maximum length of field}
  f_dec  : byte;          {number of decimal places}
  f_typ  : char;          {field type}
  f_pos  : byte;          {same purpose as first byte of pascal string}
  case integer of
  0:(f_ptr  : f_ap);      {pointer to the actual character array}
  1:(f_o:word; f_s:word); {components of pointer}
 end;

rec_des =
 record
  f_num  : word;                         {number of fields}
  dealoc : boolean;                      {set true if memory was allocated by getmem}
  b_siz  : word;
  del_f  : ^char;                        {points to "delete" field marker}
  f_d    : array[1..128] of field_des;   {actual field descriptors}
 end;

rdptr = ^rec_des;

ptrParts = record
            o:word;
            s:word;
           end;
{------------------------------------------------------------------------------}
function DBFreset(var s:string):ghPtr;
{Reset a DBF file as untyped with a record size of 1 byte}
{Allocate space for the header on the heap and return a  }
{pointer to the header.  Return nil if open failed       }
{"s" is a string containing the file path                }

var  lf  : file;
     g   : ghPtr;
     dh  : dbfHdr;
     msz : word;

begin
 {$I-}
 DBFreset := nil;
 assign(lf,s);
 if ioresult <> 0 then exit;
 reset(lf,1);
 if ioresult <> 0 then exit;
 blockread(lf,dh,sizeOf(dbfHdr)); {read in the 32 byte header}
 {$I+}
 close(lf);                       {we will want to move the file variable anyway}
 msz := sizeOf(lf) + dh.hdrLen;   {total amount of memory to get}
 getmem(g,msz);                   {allocate it}
 DBFreset := g;                   {and return it}
 assign(g^.fil,s);
 reset(g^.fil,1);
 blockRead(g^.fil,g^.h,dh.hdrLen);  {get entire header into memory block}
end; {function DBFreset}
{------------------------------------------------------------------------------}
function DBFrecRead(g:ghPtr; r:rdptr; recNum:word):boolean;
{Read record "recNum" from dbf file with header at g^ into buffer}
{referenced by initialized rdptr "r"                             }
{true if read succeeds, else return false.                       }

var fptr : longint;
    i    : integer;

begin
 DBFrecRead := false;
 if recNum > g^.h.numRecs then exit;
 fptr := g^.h.recLen;
 fptr := fptr*(recNum-1);
 fptr := fptr + g^.h.hdrLen;
 {$I-}
 seek(g^.fil,fptr);
 if ioresult <> 0 then exit;
 blockRead(g^.fil,r^.del_f^,g^.h.recLen);
 if ioresult <> 0 then exit;
 DBFrecRead := true;
 with r^ do                                  {set all the string counters to full}
  for i := 1 to f_num do
   f_d[i].f_pos := f_d[i].f_len;
 {$I+}
end; {function DBFrecRead}
{------------------------------------------------------------------------------}
function DBFrecWrite(g:ghPtr; r:rdptr; recNum:word; deleted:boolean):boolean;
{Write data referenced by "r" to file referenced by "g" as    }
{record "recNum".  If "recNum" = file size + 1, appends the   }
{record and returns true.  If larger than that, returns false }
{also returns false if IO error                               }
{if if "deleted" is true, then record is written as deleted   }

var fptr : longint;

begin
 DBFrecWrite := false;
 if recNum > g^.h.numRecs then
  begin
   if (recNum - 1) > g^.h.numrecs then exit;
   inc(g^.h.numrecs);
  end; {if recNum > g^.h.numRecs}
 fptr := g^.h.recLen;
 fptr := fptr*(recNum-1);
 fptr := fptr + g^.h.hdrLen;
 seek(g^.fil,fptr);
 if ioresult <> 0 then exit;
 if deleted then r^.del_f^ := '*'
 else r^.del_f^ := ' ';                     {fill "deleted" field appropriately}
 blockWrite(g^.fil,r^.del_f^,g^.h.recLen);
 if ioresult <> 0 then exit;
 DBFrecWrite := true;
end; {function DBFrecWrite}
{------------------------------------------------------------------------------}
procedure DBFclose(g:ghPtr; r:rdptr; altered:boolean);
{close the file referenced by "g".  If altered is true, update the}
{date and write out the header - which may have been modified if  }
{any records were appended.  Closes the file and frees memory used}
{by the header for it.  Also frees memory used by "r" if the flag }
{dealoc is set                                                    }

const trailer : word = $000d;

var yr,mn,dy,dow,msz : word;
    tail             : ^byte;
    wt               : ^word absolute tail;
    pp               : ptrParts absolute tail;

begin
 if altered then
  begin
   getDate(yr,mn,dy,dow);                  {set the date in the header}
   with g^.h do
    begin
     lrevYear := lo(yr mod 100);           {low two digits of year}
     lrevMo   := lo(mn);
     lrevDay  := lo(dy);
     msz := 32*(numRecs + 1);              {get size of header data}
     pointer(tail) := g;                   {make pointer to the trailing seperator}
     inc(pp.s,msz div 16);
     inc(pp.o,msz mod 16);                 {advance pointer}
     msz := hdrLen - msz;                  {see how many trailing bytes}
     if msz > 1 then wt^ := trailer        {if two, write a word}
     else tail^ := lo(trailer);            {if one, write a byte}
    end; {with g^.h}
   seek(g^.fil,0);                         {top of the file}
   blockWrite(g^.fil,g^.h,sizeOf(dbfhdr)); {write out the altered header}
  end; {if altered}
 close(g^.fil);
 msz := sizeOf(g^.fil) + g^.h.hdrLen;
 freemem(g,msz);                           {free the memory used by g}
 if r^.dealoc then
  freemem(r,sizeOf(rec_des));              {if flag set, free memory used by recdes}
end; {procedure DBFclose}
{------------------------------------------------------------------------------}
procedure fillRec_des(g:ghPtr; var r:rdptr; var buf:pointer);
{Fill in the rec_des referenced by "r" from the data in "g" which }
{must, of course, be initiaized.  if "buf" is not nil then "r"    }
{is set up to reference it and b_siz is left zero.  If nil, space }
{is allocated on heap and the b_siz field of "r" is filled in     }
{BE SURE NOT TO CALL THIS WITH AN UNINITALIZED POINTER IN BUF OR R}

var i,numfld,j  : integer;
    bofs        : word;
    pp          : ptrParts absolute buf;

begin
 if r = nil then
  begin
   getmem(r,sizeOf(rec_des));                         {initialize r if nil}
   fillchar(r^,sizeOf(rec_des),0);                    {initialize to nulls}
   r^.dealoc := true;                                 {set flag to deallocate}
  end; {if r = nil}
 if buf = nil then                                    {allocate buffer if needed}
  begin
   getmem(buf,g^.h.recLen);
   r^.b_siz := g^.h.recLen;
  end; {if buf = nil}
 with pp do                                           {normalize "buf" pointer}
  begin
   if o > 16 then
    begin
     inc(s,o div 16);
     o := o mod 16;
    end; {if o > 16}
  end; {with pp}
 numfld := g^.h.hdrLen;                               {calculate number of fields from header size}
 dec(numfld,numfld mod 32);                           {delete trailer}
 numfld := (numfld div 32) - 1;                       {number of 32 byte entries - dbfHdr}
 pointer(r^.del_f) := buf;                            {the delete field is at base of buffer}
 bofs := 1;                                           {and we are now offset 1 in the buffer}
 r^.f_num := numfld;
 for i := 1 to numfld do                              {now, initialize "r" field by field}
  begin
   with r^.f_d[i] do
    begin
     j := 1;                                          {copy field name}
     while g^.f[i].field_name[j] <> #0 do
      begin
       f_name := f_name + g^.f[i].field_name[j];
       inc(j);
      end; {while g^.f[i].field_name[j] <> #0}
     f_typ := g^.f[i].field_typ;                      {copy field type}
     f_dec := g^.f[i].dec_pl;                         {decimal specifier}
     f_len := g^.f[i].f_len;                          {length}
     f_o := pp.o + bofs mod 16;                       {set offset of pointer}
     f_s := pp.s + bofs div 16;                       {and segment}
     inc(bofs,f_len);                                 {ready offset for next round}
    end; {with r^.f_d[i]}
  end; {for i := 1 to numfld}
end; {procedure fillRec_des}
{------------------------------------------------------------------------------}
procedure setCfield(var fd:field_des; s:string);
{set a character field to contain the passed string parameter}

var  len : integer;

begin
 with fd do
  begin
   if f_typ <> 'C' then exit;         {quit if field type wrong}
   fillchar(f_ptr^,f_len,$20);        {fill field with spaces  }
   len := length(s);
   if len > f_len then len := f_len;  {don't overfill}
   move(s[1],f_ptr^,len);             {move string into field}
   f_pos := len;
  end; {with fd}
end; {procedure setCfield}
{------------------------------------------------------------------------------}
procedure setNfield(var fd:field_des; val:real);
{set a numeric field from given value which must be a real}

var  nstr : string[20];

begin
 with fd do
  begin
   if f_typ <> 'N' then exit;
   fillchar(f_ptr^,f_len,$20);
   str(val:f_len:f_dec,nstr);          {make a string of the value}
   if length(nstr) > f_len then exit;  {leave empty if overflow}
   move(nstr[1],f_ptr^,f_len);         {otherwise, length is ok - just move}
   f_pos := f_len;
  end; {with fd}
end; {procedure setNfield}
{------------------------------------------------------------------------------}
procedure setLfield(var fd:field_des; val:boolean);
{put the given value into the logical field}

begin
 with fd do
  begin
   if f_typ <> 'L' then exit;
   if val then f_ptr^[1] := 'T'
   else f_ptr^[1] := 'F';
   f_pos := 1;
  end; {with fd}
end; {procedure setLfield}
{------------------------------------------------------------------------------}
procedure setDfield(var fd:field_des; year,month,day:integer);
{put the given year, month, and day into date field}

var nst : string[4];
    st  : string[10];

begin
 with fd do
  begin
   if f_typ <> 'D' then exit;
   str(year:4,st);
   str(month,nst);
   if (length(nst) < 2) then insert('0',nst,1);
   st := st + nst;
   str(day,nst);
   if (length(nst) < 2) then insert('0',nst,1);
   st := st + nst;
   move(st[1],f_ptr^,10);
   f_pos := 10;
  end; {with fd}
end; {procedure setDfield}
{------------------------------------------------------------------------------}
procedure setMfield(var fd:field_des; blkNum:longint);
{set the memo field like a numeric field with block number blkNum}

var nst : string[10];

begin
 with fd do
  begin
   if f_typ <> 'M' then exit;
   str(blkNum:10,nst);
   move(nst[1],f_ptr^,10);
   f_pos := 10;
  end; {with fd}
end; {procedure setMfield}
{------------------------------------------------------------------------------}
procedure getCfield(var fd:field_des; var s:string);
{get contents of field into string                                  }
{does not type check the field, so any field can be read as a string}

var  len : integer;

begin
 with fd do
  begin
   len := f_pos;
   while (f_ptr^[len] = ' ')AND(len > 0) do dec(len);  {hunt last non white space char}
   s[0] := chr(len);
   move(f_ptr^,s[1],len);
  end; {with fd}
end; {procedure getCfield}
{------------------------------------------------------------------------------}
procedure getNfield(var fd:field_des; var valu:real);
{return value of the numeric field in valu}

var  nst : string[10];
     b   : byte absolute nst;
     cod : integer;

begin
 valu := 0;
 with fd do
  begin
   if f_typ <> 'N' then exit;
   getCfield(fd,nst);                                {get the field as a string}
   while(nst[1] = ' ')AND(b>0) do delete(nst,1,1);   {delete leading spaces}
   while(nst[b] = ' ')AND(b>0) do dec(b);            {trim trailing spaces}
   val(nst, valu, cod);                              {evaluate the string}
   if cod <> 0 then valu := 0;                       {set back to zero if error}
  end; {with fd}
end; {procedure getNfield}
{------------------------------------------------------------------------------}
procedure getLfield(var fd:field_des; var val:boolean);
{return the boolean state in val}

begin
 with fd do
  begin
   if f_typ <> 'L' then exit;
   val := (f_ptr^[1] in ['T','t','Y','y']);
  end; {with fd}
end; {procedure getLfield}
{------------------------------------------------------------------------------}
procedure getDfield(var fd:field_des; var year,month,day:integer);
var  dst : string[10];
     nst : string[4];
     cod : integer;
begin
 with fd do
  begin
   if f_typ <> 'D' then exit;
   getCfield(fd,dst);                        {get date as string}
   nst := copy(dst,1,4);                     {get year}
   val(nst,year,cod);
   if cod <> 0 then exit;
   nst := copy(dst,5,2);
   val(nst,month,cod);
   if cod <> 0 then exit;
   nst := copy(dst,8,2);
   val(nst,day,cod);
  end; {with fd}
end; {procedure getDfield}
{------------------------------------------------------------------------------}
procedure getMfield(var fd:field_des; var blkNum:longint);
{get the block number in a memo field as a longint}

var  nst : string[10];
     b   : byte absolute nst;
     cod : integer;

begin
 blkNum := 0;
 with fd do
  begin
   if f_typ <> 'N' then exit;
   getCfield(fd,nst);                                {get the field as a string}
   while(nst[1] = ' ')AND(b>0) do delete(nst,1,1);   {delete leading spaces}
   while(nst[b] = ' ')AND(b>0) do dec(b);            {trim trailing spaces}
   val(nst, blkNum, cod);                            {evaluate the string}
   if cod <> 0 then blkNum := 0;                     {set back to zero if error}
  end; {with fd}
end; {procedure getMfield}
{------------------------------------------------------------------------------}

type charCel = record
                case integer of
                0:(c:char; a:byte);
                1:(b:byte; atr:byte);
                2:(w:word);
               end;
     hexByte = record
                hi : charCel;
                lo : charCel;
                sp : charCel;
               end;
     scrLine = record
                hexb  : array[0..15] of hexByte;
                spa   : array[0..9]  of charCel;
                litrl : array[0..15] of charCel;
                spb   : array[0..5]  of charCel;
               end;

     screen = record
              case integer of
              0:(scrn : array[1..25] of scrLine);
              1:(clr  : array[1..2000] of word);
              2:(cc   : array[0..1999] of charCel);
              end;

     pgraf = array[0..15] of byte;
     pgp   = ^ pgraf;

     ptrstuf = record
                case integer of
                0:(p:pointer);
                1:(o:word; s:word);
                2:(a:pgp);
                end;





type bufr =  array[1..$fffe] of byte;
     bp   = ^bufr;

const hexChr : array[0..15] of char =
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');


var  iofil  : file;
     iobuf  : bp;
     buflen : word;
     bufpos : word;
{------------------------------------------------------------------------------}
 function getkey:word;
 inline(
        $B4/$00/   {mov ah,0}
        $CD/$16    {int 16h}
        );
{------------------------------------------------------------------------------}
procedure clrScr;
inline(
       $B8/>$B800/  {mov   ax,0b800h}
       $8E/$C0/   {mov   es,ax}
       $33/$FF/   {xor   di,di}
       $B9/>$07D0/  {mov   cx,2000}
       $B8/>$0720/  {mov   ax,0720h}
       $9C/       {pushf}
       $FC/       {cld}
       $F3/$AB/   {rep   stoss}
       $9D        {popf}
       );
{------------------------------------------------------------------------------}
procedure Help;
{show a help screen}
begin
clrscr;
writeln('DBFFIX is a simple binary file editor that will also show the file as');
writeln('a dBase III format header to allow repair of corrupted files in this format.');
writeln('It is limited to files of 65530 bytes in length.');
writeln('                                         ');
writeln('EDITING KEYSTROKES                     | STANDARD KEYSTROKES');
writeln('                                       | Keystokes that send an ascii code');
writeln('F1: Display this help screen           | overwrite the active byte like this:');
writeln('F2: Show the buffer as a dBase header  | ');
writeln('    with the active field specification| On the Hex side:');
writeln('    shown directly below the header    | 0-1 and A-F (case insensitive)');
writeln('F5: Switch from Hex side to Ascii side | can be used to generate a 2 char hex');
writeln('F10:Exit and save file                 | string.  If the string is not valid');
writeln('Right Arrow: Move forward  1 byte      | you get a beep and nothing else');
writeln('Left  Arrow: Move backward 1 byte      |');
writeln('Up    Arrow: Move up a line            | On the Ascii side:');
writeln('Down  Arrow: Move down a line          | The input ascii code overwrites');
writeln('Page Up    : Move up 24 lines          | the buffer directly.  Alt-keypad');
writeln('Page Down  : Move down 24 lines        | input works also.');
writeln('alt X:       Exit without save.        |');
writeln('Del:         Delete byte at cursor     | The active side is the red cursor.');
writeln('Ins:         Insert nul byte at cursor |');
writeln(^J'            <Hit any key to continue>');
if getkey = 0 then ;
end; {procedure Help}
{------------------------------------------------------------------------------}
procedure shoBufrAsHdr(p:bp; pos:word; startfield:integer);
{show the buffer as a dbf header}

type hstruc = record
               h : dbfHdr;
               f : array[1..128] of dbfFldDes;
              end;
     hsptr = ^ hstruc;

var  hp : hsptr absolute p;
     i  : integer;

begin
 clrscr;
 with hp^ do
  begin
   writeln('Version           : ',h.dBIIIvers);
   writeln('Year              : ',h.lrevYear);
   writeln('Month             : ',h.lrevMo);
   writeln('Day               : ',h.lrevDay);
   writeln('Number of records : ',h.numRecs);
   writeln('Header Length     : ',h.hdrLen);
   writeln('Record Length     : ',h.recLen);
   for i := 0 to 3 do
    begin
     with f[i+startFIeld] do
      begin
       writeln('Field Name     : ',field_name);
       writeln('Field Type     : ',field_typ);
       writeln('Field Length   : ',f_len);
       writeln('Decimal Places : ',dec_pl);
      end; {with f[i+startFIeld]}
    end; {for i := 0 to 3}
  end; {with hp^}
end; {procedure shoBufrAsHdr}
{------------------------------------------------------------------------------}
function getFile(s:string; var len:word; var p:bp):boolean;
begin
 getFile := false;
 if pos('.',s) = 0 then s := s + '.dbf';
 {$I-}
 assign(iofil,s);
 if ioresult <> 0 then exit;
 reset(iofil,1);
 if ioresult <> 0 then exit;
 getmem(p,$fffe);
 blockRead(iofil,p^,$fffe,len);
 if ioresult <> 0 then exit;
 getFile := true;
end; {function getFile}
{------------------------------------------------------------------------------}
procedure paintBufr(base,pos:pointer;hside:boolean);
{paint the buffer on the screen and mark "pos" in inverse video}


var  b,p  : ptrstuf;
     disp : screen absolute $b800:0;
     i,j  : integer;

begin
 for i := 1 to 2000 do disp.clr[i] := $1720;  {clear the screen}
 b.p := base;
 for i := 1 to 25 do
  begin
   for j := 0 to 15 do
    begin
     with disp.scrn[i] do
      begin
       hexb[j].hi.c := hexChr[b.a^[j] shr 4];
       hexb[j].lo.c := hexChr[b.a^[j] and $0f];
       litrl[j].b   := b.a^[j];
      end; {with disp.scrn[i]}
    end; {for j := 0 to 15}
   inc(b.s);
  end; {for i := 1 to 25}
 b.p := base;
 p.p := pos;
 i := (p.s-b.s);
 j := p.o-b.o;
 i := i + j div 16;
 j := j mod 16;
 inc(i);

 if j < 0 then
  begin
   inc(j,16);
   dec(i);
  end; {if j < 0}
 with disp.scrn[i] do
  begin
   if hside then
    begin
     hexb[j].hi.a := $40;
     hexb[j].lo.a := $40;
     litrl[j].a   := $1f;
    end   {if hside}
   else
    begin
     hexb[j].hi.a := $1f;
     hexb[j].lo.a := $1f;
     litrl[j].a   := $40;
    end; {else for if hside}
  end; {with disp.scrn[i]}
end; {procedure paintBufr}
{------------------------------------------------------------------------------}
function HexEdit(buf:bp):byte;
{allow edit of buffer in hex mode}
{returns scan code of key that was hit to exit}

type ksparts = (asci,scan);

var bufpos   : word;
    shoBase  : ptrStuf;
    kw       : word;
    kp       : array[ksparts] of byte absolute kw;
    kc       : array[ksparts] of char absolute kw;
    hside,ok : boolean;
    poslin   : integer;
    posDelt  : word;
    hexinp   : array[1..2] of char;
    i,j      : integer;

begin
 for i := 1 to 24 do writeln;  {move cursor to bottom of screen}
 posDelt := 0;
 hside := true;
 shoBase.p := buf;
 bufpos := 1;
 repeat
  paintBufr(shoBase.p,@buf^[bufpos],hside);
  kw := getkey;
  hexEdit := kp[scan];
  case kp[scan] of  {looking for scan codes to implement editing functions}
   $3b : help;
   $44 : exit;                                {exit on F10}
   $3c : begin                                {F2 shows buffer as header}
          shoBufrAsHdr(buf,bufPos,bufPos div 32);
          kw := getkey;
         end;
   $2d : if kp[asci] = 0 then exit;           {also exit on alt X}
   $3f : hside := not(hside);                 {toggle sides on F5}
   $48 : if bufpos > 16 then dec(bufpos,16);  {up arrow goes up 16 bytes}
   $50 : if buflen - bufpos > 16 then
          inc(bufpos,16);                     {down arrow goes down 16}
   $4b : if bufpos > 1 then dec(bufpos);      {left arrow goes back 1}
   $4d : if bufpos < buflen then inc(bufpos); {right arrow goes forward 1}
   $49 : if bufpos > 16*24 then               {page up moves up 24 lines}
          begin
           dec(bufpos,16*24);
           dec(posDelt,24);
          end; {if bufpos > 16*24}
   $51 : if (buflen - bufpos) > 16*24 then    {page down goes forward 24 lines}
          begin
           inc(bufpos,16*24);
           inc(posDelt,24);
          end; {if (buflen - bufpos) > 16*24}
   $53 : begin                                {del}
          dec(bufLen);
          move(buf^[bufpos+1],buf^[bufpos],bufLen-bufpos); {delete byte at bufpos}
         end;
   $52 : begin                                {ins}
          move(buf^[bufpos],buf^[bufpos+1],bufLen-bufpos); {move up to insert}
          inc(bufLen);
          buf^[bufpos] := 0;                  {insert a nul at bufpos}
         end;

   else if kp[asci] <> 0 then begin           {input keyboard character}
          if hside then
           begin
            hexinp[1] := upcase(kc[asci]);    {accumulate chars in string}
            kw := getkey;
            hexinp[2] := upcase(kc[asci]);
            ok := true;
            for i := 1 to 2 do
             begin
              j := 0;
              while (hexinp[i] <> hexChr[j])AND
                    (j <= 15) do inc(j);
              if j < 16 then hexinp[i] := chr(j)
              else ok := false;
             end; {for i := 1 to 2}
            if ok then
             begin
              buf^[bufPos] := ord(hexinp[1]) shl 4 + ord(hexinp[2]);
             end  {if ok}
            else write(^G);       {beep on error}
           end  {if hside}
          else buf^[bufPos] := kp[asci];      {overwrite buffer with input keystroke}
         end;
  end; {case}
  poslin := (bufpos - 1) div 16;
  if poslin < posDelt then  posDelt := poslin;
  if poslin > (posDelt + 24) then posDelt := poslin - 24;
  shoBase.p := buf;
  shoBase.s := shoBase.s + posDelt;
 until false;
end; {function HexEdit}
{------------------------------------------------------------------------------}
procedure writeFile(s:string; len:word; p:pointer);
begin
 close(iofil);
 if pos('.',s) = 0 then s := s + '.dbf';
 assign(iofil,s);
 rewrite(iofil,1);
 blockWrite(iofil,p^,len);
end; {procedure writeFile}
{------------------------------------------------------------------------------}
begin
 writeln('Copyright (c) 1992');
 writeln('Quaker Hill Software, Inc.');
 writeln('29 Colonel Wilkins Road');
 writeln('Amherst, NH 03031');
 writeln('603 672 5224');
 writeln(^J'Released to the public domain 1992');
 if paramcount < 2 then
  begin
   writeln(^J'USAGE');
   writeln('DBFFIX inputfile outputfile');
   halt(255);
  end; {if paramcount < 2}
 if getFile(paramstr(1),buflen,iobuf) then
  begin
   if hexedit(iobuf) = $44 then      {if exited on F10, write file}
    writeFile(paramStr(2),buflen,iobuf);
  end; {if getFile(paramstr(1),buflen,iobuf)}
 {$I-}
 close(iofil);
 clrscr;
end.