type
   string = varying [255] of char;
   packed_string = packed array [1..512] of char;

var
   dbf : file of packed_string;
   rec : packed_string;
   recptr : integer;

procedure dbf_open(tablename:string);

begin
   open(dbf,tablename+'.DBF',new,record_type:=fixed,record_length:=512);
   rewrite(dbf);
   recptr:=0;
end;

procedure dbf_put_str(s:string);

var
   i : integer;

begin
   for i:=1 to length(s) do begin
      recptr:=recptr+1;
      rec[recptr]:=s[i];
      if (recptr=512) then begin
         dbf^:=rec;
         put(dbf);
         recptr:=0;
      end;
   end;
end;

procedure dbf_put_byte(b:integer);

begin
   dbf_put_str(chr(b));
end;

procedure dbf_put_word(w:integer);

var
   tmp,i : integer;

begin
   tmp:=w;
   for i:=1 to 2 do begin
      dbf_put_byte(tmp mod 256);
      tmp:=tmp div 256;
   end;
end;

procedure dbf_put_longword(lw:integer);

var
   tmp,i : integer;

begin
   tmp:=lw;
   for i:=1 to 4 do begin
      dbf_put_byte(tmp mod 256);
      tmp:=tmp div 256;
   end;
end;

procedure dbf_put_header(nfields,nrecords,recordwidth:integer);

var
   i : integer;

begin
   dbf_put_byte(3);
   dbf_put_byte(95);
   dbf_put_byte(1);
   dbf_put_byte(1);
   dbf_put_longword(nrecords);
   dbf_put_word(32+nfields*32+1);
   dbf_put_word(1+recordwidth);
   for i:=1 to 20 do dbf_put_byte(0);
end;

procedure dbf_add_field(fieldname:string;fieldtype:char;fieldwidth:integer);

var
   i : integer;
   tmp : string;

begin
   tmp:=fieldname;
   for i:=(length(fieldname)+1) to 11 do tmp:=tmp+chr(0);
   dbf_put_str(tmp);
   dbf_put_str(fieldtype);
   dbf_put_longword(0);
   dbf_put_byte(fieldwidth);
   dbf_put_byte(0);
   for i:=1 to 14 do dbf_put_byte(0);
end;

procedure dbf_nomore_fields;

begin
   dbf_put_byte(13);
end;

procedure dbf_start_record;

begin
   dbf_put_str(' ');
end;

procedure dbf_add_character(character:string;width:integer);

var
   i : integer;

begin
   dbf_put_str(character);
   for i:=(length(character)+1) to width do dbf_put_str(' ');
end;

procedure dbf_add_numeric(numeric:integer;width:integer);

var
   tmp : string;

begin
   writev(tmp,numeric:width);
   dbf_put_str(tmp);
end;

procedure dbf_close;

var
   i : integer;

begin
   dbf_put_byte(26);
   if (recptr<>0) then begin
      for i:=(recptr+1) to 512 do rec[i]:=chr(0);
      dbf^:=rec;
      put(dbf);
   end;
   close(dbf);
end;
