Program pre spravu objednávok žalúzií.

{ READ_DBF.PAS              Copyright (c) TrSek alias Zdeno Sekerak }
{ Unit urceny pre citanie DBF citanie/zapis suborov, reindexaciu.   }
{                                                                   }
{ Datum:19.06.1995                            http://www.trsek.com  }
 
unit READ_DBF;
 
interface
uses crt,dos,kniznic;
const max_viet=80;    { max - kolko moze byt maximalne premennych v 1 vete }
      k_index='.ind';                                   { koncovka pre subor s indexami }
      k_dbf='.dbf';                                     { koncovka pre DBF subor }
      max_ind=5000;
 
type premenna=(C,L,N,D);
                       { typ premennej C-retazec, L-logicka, N-numericka }
                       {               D-datum }
   hlava=record                     { typ tzv. hlavy DBF blizie informacie }
     nazov: array[1..11] of char;   { na horeuvedenej adrese }
     typep: char;
       zac: word;
     none2: array[1..2] of byte;
      size: byte;
     desat: byte;
     none3: array[1..14] of byte;
     end;
 
type   index = word;               { typ indexoveho suboru                 }
 
 
var         base : array[1..max_viet] of string;   { polozky jednej vety                  }
           hlavy : array[1..max_viet] of hlava;    { hlavy (popisy) kazdej z poloziek     }
          indexy : array[1..max_ind]  of index;    { Global indexov }
 
         {  base : tbase;
           hlavy : thlavy;
          indexy : tindexy;}
                f: file of char;   { nacitava jednotlive vety DBF          }
               ff: file of hlava;  { nacitava hlavy DBF                    }
    poc,dtab,dvet: word;           { poc-pocet viet, dtab-dlzka tabulky    }
                                   { hlavy, dvet-velkost jednej vety v kB  }
             spoc: word;           { Realny, skutocny pocet viet           }
      den,mes,rok: byte;           { den,mesiac,rok z DBF                  }
           typdbf: byte;           { typ dBase, prvy byt DBF               }
               pp: integer;        { pp-pocet premennych vo vete           }
                                   { rpp-kolko premennych vypisat z vety   }
          AllSize: LongInt;        { celkova velkost suboru DBF            }
         SAllSize: LongInt;        { Skutocna celkova velkost suboru DBF   }
              i,x: integer;        { pomocne premenne                      }
           fyzvet: word;           { cislo aktualnej (fyzickej) vety v DBF }
           relvet: word;           { cislo relativnej vety                 }
 r_od,r_do,r_size: longint;        { od,do fyzicky precital dbf            }
            quick: pointer;        { pointer na fyzicke citanie dbf        }
            kolko: longint;        { kolko je fyzicky citane               }
 
 
function  nothing    ( i :integer) :string;
procedure closebase;
procedure opendbase  ( meno :string );
function  get_index  ( i_subor :string; i:word ) :word;
procedure put_index  ( i_subor :string; p,i:word );
procedure r_read     ( subor:string; r_seek:longint);
procedure r_write    ( subor:string );
procedure write_poc  ( meno:string; poc:word );
procedure cit_mem    ( meno:string; dbf_veta:longint );
procedure zap_mem    ( meno:string; dbf_veta:longint );
procedure cit_vety   ( meno :string; dbf_veta:word );
procedure zap_vety   ( meno :string; dbf_veta:word );
procedure clear_all_index;
procedure put_all_index ( meno :string );
implementation
 
function nothing(i:integer):string;
begin
 nothing:=copy('                                                                                ',1,i);
end;
 
procedure closebase;
begin
 freemem(quick,kolko);
 kolko:=0;
end;
 
procedure opendbase(meno:string);                    { otvor DBF a precitaj z nej hlavy }
var sub:SearchRec;
     ch:char;
     p:word;
   i_f:file of index;
   akt:integer;
begin
 
 if kolko>0 then closebase;
 assign(f,meno+k_dbf);
 {$I-}
 reset(f);
 {$I+}                                  { ak DBF nejestvuje }
 if ioresult<>0 then begin
    writeln('Subor bud nejestvuje, alebo nieje spravna cesta.');
    halt(0);
    end;
 
 findfirst(meno+k_dbf,Archive,Sub);           { zisti jeho velkost }
 AllSize:=Sub.Size;
 SAllSize:=Sub.Size;
 read(f,ch);typdbf:=ord(ch);            { precitaj uvodne info typ dBase      }
 read(f,ch);rok:=ord(ch);               { den, mesiac, rok poslednej editacie }
 read(f,ch);mes:=ord(ch);
 read(f,ch);den:=ord(ch);
 
 read(f,ch);poc:=ord(ch);
 read(f,ch);poc:=poc+256*ord(ch);
 spoc:=poc;                             { Aky je skutocny pocet viet }
 for i:=1 to 3 do read(f,ch);
                                        { zisti velkost tabulky hlav }
 dtab:=ord(ch);read(f,ch);dtab:=dtab+256*ord(ch);
 pp:=round(dtab/32)-1;                  { dtab/32-1= pocet premennych }
                                        { ale vypisuje najviac 20 z jednej vety }
 read(f,ch);dvet:=ord(ch);
 read(f,ch);dvet:=dvet+256*ord(ch);     { zisti dlzku jednej vety }
 close(f);
 
 assign(ff,meno+k_dbf);
 reset(ff);
 read(ff,hlavy[1]);                     { toto precita hlavu hlav }
                                        { pekne sprosto som to nazval }
 for i:=1 to pp do
  read(ff,hlavy[i]);                    { toto cita hlavu kazdej premennej }
 close(ff);                             { co vsetko obsahuje ??? }
                                        { kontakt na programatora je v zahlavy }
 for i:=1 to pp do
  case hlavy[i].typep of                { nastavi velkost premennych pre jednotlive }
                                        { premenne podla hlavy }
   'C':base[i]:=nothing(hlavy[i].size);
   'L':base[i]:=nothing(1);
   'N':if hlavy[i].desat>0 then base[i]:=nothing(hlavy[i].size)
                           else base[i]:=nothing(hlavy[i].size+hlavy[i].desat);
   'D':base[i]:=nothing(8);
   end;
 
   FindFirst(meno+k_index,Archive,Sub);
   if DosError<>0 then begin
      hlaska('Vytvaram INDEXOVY subor '+meno+k_index,-1);
      akt:=0;clear_all_index;
      for p:=1 to poc do begin
          inc(akt);indexy[akt]:=p;
          if akt>=max_ind then begin
             put_all_index(meno);
             akt:=0;
             end;
          end;
      put_all_index(meno);
      hlaska('                                     ',-1);
      end
     else begin
      assign(i_f,meno+k_index);
      reset(i_f);
      poc:=FileSize(i_f)-1;
      AllSize:=dtab+1+longint(poc)*longint(dvet);
      close(i_f);
      end;
{ Kvoli rychlosti ...}
 
  FindFirst(meno+k_dbf,Archive or Hidden or ReadOnly,sub);
  kolko:=MaxAvail;
  if MaxAvail>66035 then kolko:=65535
                    else kolko:=MaxAvail-500;
 
  if kolko>Sub.Size then kolko:=Sub.Size;
  kolko:=round(MaxAvail/2);
  r_size:=Sub.Size;
  getmem(quick,kolko);
  r_od:=0;r_do:=0;
end;
 
function get_index(i_subor:string;i:word):word;
var   i_f:file of index;
  p_index:index;
begin
 p_index:=0;
 assign(i_f,i_subor+k_index);
 {$I-}
 reset(i_f);
 if FileSize(i_f)>i then begin
    seek(i_f,i);
    read(i_f,p_index);
 
    { Dodatocne uprav Globalne premenne pocet a Velkost DBF }
    poc:=FileSize(i_f)-1;
    AllSize:=dtab+1+longint(poc)*longint(dvet);
   end                          { Co ak sa pyta na neexistujuci index ??? }
   else p_index:=0;
 {$I+}
 if IoResult=0 then close(i_f);
 
 get_index:=p_index
end;
 
procedure put_index(i_subor:string;p,i:word);
var   i_f:file of index;
  p_index:index;
       pp:word;
begin
  p_index:=0;
  assign(i_f,i_subor+k_index);
  {$I-}
  Reset(i_f);
  {$I-}
  if IoResult<>0 then
     ReWrite(i_f);
 
  if FileSize(i_f)<=p then
     for pp:=p to FileSize(i_f) do begin
         seek(i_f,pp);write(i_f,p_index);
         end;
  seek(i_f,p);
  write(i_f,i);
 
  { Dodatocne uprav Globalne premenne pocet a Velkost DBF }
  poc:=FileSize(i_f)-1;
  AllSize:=dtab+1+longint(poc)*longint(dvet);
 
  close(i_f);
end;
 
procedure r_read(subor:string;r_seek:longint);
var ff1:file;
    err:word;
begin
 Assign  (ff1,subor);
 {$I-}
 ReSet   (ff1,1);
 {$I+}
 if IoResult<>0 then exit;
 if r_seek>r_size then begin close (ff1);exit;end;
 
 r_od:=r_seek;r_do:=r_seek+kolko;
 if r_do>r_size then r_do:=r_size;
 
 Seek(ff1,r_od);
 BlockRead  (ff1,quick^,word(r_do-r_od),err);
 if err>word(r_do-r_od) then hlaska('Chyba fyzickeho citania DBF opusti program !!!',0);
 
 close (ff1);
end;
 
procedure r_write( subor:string );
var ff1:file;
    err:word;
begin
 Assign  (ff1,subor);
 {$I-}
 ReSet   (ff1,1);
 {$I+}
 if IoResult<>0 then exit;
 
 Seek(ff1,r_od);
 BlockWrite (ff1,quick^,word(r_do-r_od),err);
 if err>word(r_do-r_od) then hlaska('Chyba fyzickeho citania DBF opusti program !!!',0);
 
 close (ff1);
end;
 
procedure write_poc ( meno:string; poc:word );
var f:file of byte;
    b1,b2:byte;
    porov:longint;
begin
  b1:=trunc(poc/256);b2:=poc-b1*256;
 
  assign(f,meno+k_dbf);
  reset(f);
  seek(f,4);
  write(f,b2);write(f,b1);
 
  porov:=dtab+longint(poc)*longint(dvet);
  seek(f,porov);
  truncate(f);
  close(f);
 
  SAllSize:=dtab+longint(poc)*longint(dvet);
  AllSize:=SAllSize;
end;
 
procedure cit_mem( meno:string; dbf_veta:longint );
var  p:pointer;
     i:integer;
 zacni:longint;
begin
 zacni:=dtab+LongInt(dbf_veta)*LongInt(dvet)+1;
 if zacni+dvet>r_do then r_read(meno,zacni);
 if zacni     <r_od then r_read(meno,zacni);
 
 p:=Ptr(Seg(quick^),Ofs(quick^)+zacni-r_od);
 
 for x:=1 to pp do                     { nastrka to do premennych }
  for i:=1 to hlavy[x].size do begin
   base[x][i]:=chr(byte(p^));
   p:=Ptr(Seg(p^),Ofs(p^)+1);
   end;
end;
 
procedure zap_mem( meno:string; dbf_veta:longint );
var   p:pointer;
      i:integer;
  zacni:longint;
  nutne:boolean;
begin
 nutne:=false;
 zacni:=dtab+LongInt(dbf_veta)*LongInt(dvet)+1;
 p:=Ptr(Seg(quick^),Ofs(quick^)+zacni-r_od);
 
 if zacni+dvet>r_size then begin
    zacni:=r_od+dvet;
    r_read(meno,zacni);
    r_do:=r_do+dvet;
    r_size:=r_size+dvet;
    r_write(meno);
   end;
 
 for x:=1 to pp do                     { nastrka to do premennych }
  for i:=1 to hlavy[x].size do begin
   if base[x][i]<>chr(byte(p^)) then begin
      byte(p^):=ord(base[x][i]);
      nutne:=true;
     end;
   p:=Ptr(Seg(p^),Ofs(p^)+1);
   end;
 
 if nutne then r_write(meno);
end;
 
procedure cit_vety(meno:string; dbf_veta:word);
var     p:integer;
    porov:LongInt;
begin
 relvet:=dbf_veta;
 dbf_veta:=get_index(meno,dbf_veta);
 fyzvet:=dbf_veta;
 if dbf_veta<1 then exit;
 dbf_veta:=dbf_veta-1;
 
 porov:=dtab+longint(dbf_veta+1)*longint(dvet);
 if (Porov>SAllSize) then exit;
 cit_mem(meno+k_dbf,dbf_veta);
end;
 
procedure zap_vety( meno:string; dbf_veta:word);
var porov:longint;
    i:word;
    p:pointer;
begin
 relvet:=dbf_veta;
 dbf_veta:=get_index(meno,dbf_veta);
 fyzvet:=dbf_veta;
 if dbf_veta<1 then begin                 { Zapis novej vety }
    dbf_veta:=spoc+1;inc(spoc);
    put_index(meno,relvet,dbf_veta);
    end;
 dbf_veta:=dbf_veta-1;
 
 porov:=dtab+longint(dbf_veta+1)*longint(dvet);
 if (Porov>SAllSize) then begin
     inc(poc);spoc:=dbf_veta+1;
     write_poc(meno,spoc);
     AllSize:=dtab+longint(poc+1)*longint(dvet);
    end;
 
 zap_mem(meno+k_dbf,dbf_veta);
end;
 
procedure clear_all_index;
var i:integer;
begin
 for i:=1 to max_ind do indexy[i]:=0;
end;
 
procedure put_all_index( meno :string );
var   i_f:file of index;
  p_index:index;
       pp:word;
        i:integer;
begin
  p_index:=0;
  assign(i_f,meno+k_index);
  {$I-}
  Reset(i_f);
  {$I-}
  if IoResult<>0 then begin
     ReWrite(i_f);
     seek(i_f,1);
     end;
 
  for i:=1 to max_ind do
      if indexy[i]<>0 then write(i_f,indexy[i]);
 
  { Dodatocne uprav Globalne premenne pocet a Velkost DBF }
  poc:=FileSize(i_f)-1;
  AllSize:=dtab+1+longint(poc)*longint(dvet);
 
  close(i_f);
  clear_all_index;
end;
 
end.